mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

enable inlining; speed!

Browse source 
* module/system/il/inline.scm: New module, implements generic inlining of
  scheme functions. It even does the right thing regarding (define
  arity:nopt caddr) and such. So now there are many more inlines: the
  arithmetics, `apply', the caddr family, etc. This makes the benchmarks
  *much* faster.

* module/language/scheme/translate.scm (trans): Remove the
  %scheme-primitives code in favor of the generic (scheme il inline)
  code. Adds inlining for +, -, =, etc.

* src/vm.c (vm_puts): Fix to work.

* module/system/base/compile.scm (system): Export load/compile also.

* module/system/il/compile.scm (optimize): Further debitrotting, but I
  haven't tried this function yet. It seems that <ghil-inst> was what
  <ghil-inline> is.

* module/system/il/ghil.scm (*core-primitives*, *macro-module*)
  (ghil-primitive-macro?, ghil-macro-expander, ghil-primitive?): Remove
  these unused things.

* module/system/il/macros.scm: Removed, replaced with inline.scm.

* module/system/vm/assemble.scm (stack->bytes): Before, the final
  serialization code did an (apply u8vector (apply append (map
  u8vector->list ...))). Aside from the misspelling of append-map, this
  ends up pushing all elements of the u8vector on the stack -- assuredly
  not what you want. But besides even that, I think that pushing more
  than 32k arguments on the stack brings out some other bug that I think
  was hidden before, because now we actually use the `apply' VM
  instruction. Further testing is needed here, I think. Fixed the code to
  be more efficient, which fixes the manifestation of this particular
  bug: a failure to self-compile after inlining was enabled.

* module/system/vm/bootstrap.scm: New module, serves to bootstrap
  boot-9's `load-compiled'. That way when we load (system vm core), we're
  loading compiled code already.

* module/system/vm/core.scm: Use (system vm bootstrap).

* src/guilec.in: Use the bootstrap code, so that we really are compiling
  with an entirely compiled compiler.

* module/system/repl/repl.scm (default-catch-handler): An attempt at
  making the repl print a backtrace; more work needed here.

* module/system/vm/frame.scm (make-frame-chain): Fix some misspellings --
  I think, anyway.
This commit is contained in:
Andy Wingo 2008-05-25 13:13:15 +02:00
parent 5feb8b6529
commit 22bcbe8cc9
15 changed files with 275 additions and 363 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -23,6 +23,7 @@
:use-module (system base pmatch)
:use-module (system base language)
:use-module (system il ghil)
:use-module (system il inline)
:use-module (ice-9 receive)
:use-module (srfi srfi-39)
:use-module ((system base compile) :select (syntax-error))
@ -39,9 +40,6 @@
;;; Translator
;;;
(define %scheme-primitives
'(not null? eq? eqv? equal? pair? list? cons car cdr set-car! set-cdr!))
(define %forbidden-primitives
;; Guile's `procedure->macro' family is evil because it crosses the
;; compilation boundary. One solution might be to evaluate calls to
@ -88,16 +86,15 @@
((lookup-transformer e head retrans)
=> (lambda (t) (t e l x)))
;; FIXME: lexical/module overrides of scheme primitives
((memq head %scheme-primitives)
(make-ghil-inline e l head (map retrans tail)))
;; FIXME: lexical/module overrides of forbidden primitives
((memq head %forbidden-primitives)
(syntax-error l (format #f "`~a' is forbidden" head)
(cons head tail)))
(else
(make-ghil-call e l (retrans head) (map retrans tail))))))
(let ((tail (map retrans tail)))
(or (try-inline-with-env e l (cons head tail))
(make-ghil-call e l (retrans head) tail)))))))
((symbol? x)
(make-ghil-ref e l (ghil-lookup e x)))

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

@ -30,7 +30,8 @@
:use-module (ice-9 regex)
:export (syntax-error compile-file load-source-file load-file
compiled-file-name
scheme-eval read-file-in compile-in))
scheme-eval read-file-in compile-in
load/compile))
;;;
;;; Compiler environment

2
module/system/il/Makefile.am
View file

@ -1,3 +1,3 @@
SOURCES = glil.scm macros.scm ghil.scm compile.scm
SOURCES = glil.scm ghil.scm inline.scm compile.scm
moddir = $(guiledir)/system/il
include $(top_srcdir)/guilec.mk

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

@ -41,20 +41,19 @@
(make-ghil-set env var (optimize val)))
((<ghil-if> env loc test then else)
(make-ghil-if (optimize test) (optimize then) (optimize else)))
(make-ghil-if env loc (optimize test) (optimize then) (optimize else)))
((<ghil-begin> env loc exps)
(make-ghil-begin (map optimize exps)))
(make-ghil-begin env loc (map optimize exps)))
((<ghil-bind> env loc vars vals body)
(make-ghil-bind env vars (map optimize vals) (optimize body)))
(make-ghil-bind env loc vars (map optimize vals) (optimize body)))
((<ghil-lambda> env loc vars rest body)
(make-ghil-lambda env vars rest (optimize body)))
(make-ghil-lambda env loc vars rest (optimize body)))
;; FIXME: <ghil-inst> does not exist. -- Ludo'.
; (($ <ghil-inst> inst args)
; (make-ghil-inst inst (map optimize args)))
((<ghil-inline> env loc instruction args)
(make-ghil-inline env loc instruction (map optimize args)))
((<ghil-call> env loc proc args)
(let ((parent-env env))
@ -71,9 +70,9 @@
(ghil-env-add! parent-env v))
(ghil-env-variables env)))
(else
(make-ghil-call parent-env (optimize proc) (map optimize args)))))
(make-ghil-call parent-env loc (optimize proc) (map optimize args)))))
(else
(make-ghil-call parent-env (optimize proc) (map optimize args))))))
(make-ghil-call parent-env loc (optimize proc) (map optimize args))))))
(else x)))

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

@ -81,7 +81,7 @@
<ghil-env> make-ghil-env ghil-env?
ghil-env-mod ghil-env-parent ghil-env-table ghil-env-variables
ghil-primitive-macro? ghil-env-add! ghil-lookup ghil-define
ghil-env-add! ghil-lookup ghil-define
ghil-env-toplevel?
call-with-ghil-environment call-with-ghil-bindings))
@ -112,27 +112,6 @@
(<ghil-call> env loc proc args)
(<ghil-inline> env loc inline args)))
;;;
;;; Procedures
;;;
(define *core-primitives*
'(@void @quote @define @set! @if @begin @let @letrec @lambda))
(define *macro-module* (resolve-module '(system il macros)))
(define (ghil-primitive-macro? x)
(and (module-defined? *macro-module* x)
(procedure? (module-ref *macro-module* x))))
(define (ghil-macro-expander x)
(module-ref *macro-module* x))
(define (ghil-primitive? x)
(or (memq x *core-primitives*)
(ghil-primitive-macro? x)))
;;;
;;; Variables

200
module/system/il/inline.scm Normal file
View file

@ -0,0 +1,200 @@
;;; GHIL macros
;; 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 (system il inline)
:use-module (system base syntax)
:use-module (system il ghil)
:use-module (srfi srfi-16)
:export (*inline-table* define-inline try-inline try-inline-with-env))
(define *inline-table* '())
(define-macro (define-inline sym . clauses)
(define (inline-args args)
(let lp ((in args) (out '()))
(cond ((null? in) `(list ,@(reverse out)))
((symbol? in) `(cons* ,@(reverse out) ,in))
((pair? (car in))
(lp (cdr in)
(cons `(or (try-inline ,(caar in) ,(inline-args (cdar in)))
(error "what" ',(car in)))
out)))
((symbol? (car in))
;; assume it's locally bound
(lp (cdr in) (cons (car in) out)))
((number? (car in))
(lp (cdr in) (cons `(make-ghil-quote #f #f ,(car in)) out)))
(else
(error "what what" (car in))))))
(define (consequent exp)
(cond
((pair? exp)
`(make-ghil-inline #f #f ',(car exp) ,(inline-args (cdr exp))))
((symbol? exp)
;; assume locally bound
exp)
((number? exp)
`(make-ghil-quote #f #f ,exp))
(else (error "bad consequent yall" exp))))
`(set! *inline-table*
(assq-set! *inline-table*
,sym
(case-lambda
,@(let lp ((in clauses) (out '()))
(if (null? in)
(reverse (cons '(else #f) out))
(lp (cddr in)
(cons `(,(car in)
,(consequent (cadr in))) out))))))))
(define (try-inline head-value args)
(and=> (assq-ref *inline-table* head-value)
(lambda (proc) (apply proc args))))
(define (ghil-env-ref env sym)
(assq-ref (ghil-env-table env) sym))
(define (try-inline-with-env env loc exp)
(let ((sym (car exp)))
(and (not (ghil-env-ref env sym))
(let loop ((e (ghil-env-parent env)))
(record-case e
((<ghil-mod> module table imports)
(and (not (assq-ref table sym))
(module-bound? module sym)
(try-inline (module-ref module sym) (cdr exp))))
((<ghil-env> mod parent table variables)
(and (not (assq-ref table sym))
(loop parent))))))))
(define-inline eq? (x y)
(eq? x y))
(define-inline eqv? (x y)
(eqv? x y))
(define-inline equal? (x y)
(equal? x y))
(define-inline = (x y)
(ee? x y))
(define-inline < (x y)
(lt? x y))
(define-inline > (x y)
(gt? x y))
(define-inline <= (x y)
(le? x y))
(define-inline >= (x y)
(ge? x y))
(define-inline +
() 0
(x) x
(x y) (add x y)
(x y . rest) (add x (+ y . rest)))
(define-inline *
() 1
(x) x
(x y) (mul x y)
(x y . rest) (mul x (* y . rest)))
(define-inline -
(x) (sub 0 x)
(x y) (sub x y)
(x y . rest) (sub x (+ y . rest)))
(define-inline /
(x) (div 1 x)
(x y) (div x y)
(x y . rest) (div x (* y . rest)))
(define-inline quotient (x y)
(quo x y))
(define-inline remainder (x y)
(rem x y))
(define-inline modulo (x y)
(mod x y))
(define-inline not (x)
(not x))
(define-inline pair? (x)
(pair? x))
(define-inline cons (x y)
(cons x y))
(define-inline car (x) (car x))
(define-inline cdr (x) (cdr x))
(define-inline set-car! (x y) (set-car! x y))
(define-inline set-cdr! (x y) (set-cdr! x y))
(define-inline caar (x) (car (car x)))
(define-inline cadr (x) (car (cdr x)))
(define-inline cdar (x) (cdr (car x)))
(define-inline cddr (x) (cdr (cdr x)))
(define-inline caaar (x) (car (car (car x))))
(define-inline caadr (x) (car (car (cdr x))))
(define-inline cadar (x) (car (cdr (car x))))
(define-inline caddr (x) (car (cdr (cdr x))))
(define-inline cdaar (x) (cdr (car (car x))))
(define-inline cdadr (x) (cdr (car (cdr x))))
(define-inline cddar (x) (cdr (cdr (car x))))
(define-inline cdddr (x) (cdr (cdr (cdr x))))
(define-inline caaaar (x) (car (car (car (car x)))))
(define-inline caaadr (x) (car (car (car (cdr x)))))
(define-inline caadar (x) (car (car (cdr (car x)))))
(define-inline caaddr (x) (car (car (cdr (cdr x)))))
(define-inline cadaar (x) (car (cdr (car (car x)))))
(define-inline cadadr (x) (car (cdr (car (cdr x)))))
(define-inline caddar (x) (car (cdr (cdr (car x)))))
(define-inline cadddr (x) (car (cdr (cdr (cdr x)))))
(define-inline cdaaar (x) (cdr (car (car (car x)))))
(define-inline cdaadr (x) (cdr (car (car (cdr x)))))
(define-inline cdadar (x) (cdr (car (cdr (car x)))))
(define-inline cdaddr (x) (cdr (car (cdr (cdr x)))))
(define-inline cddaar (x) (cdr (cdr (car (car x)))))
(define-inline cddadr (x) (cdr (cdr (car (cdr x)))))
(define-inline cdddar (x) (cdr (cdr (cdr (car x)))))
(define-inline cddddr (x) (cdr (cdr (cdr (cdr x)))))
(define-inline null? (x)
(null? x))
(define-inline list? (x)
(list? x))
(define-inline apply (proc . args)
(apply proc . args))
(define-inline cons*
(x) x
(x y) (cons x y)
(x y . rest) (cons x (cons* y . rest)))

302
module/system/il/macros.scm
View file

@ -1,302 +0,0 @@
;;; GHIL macros
;; 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 (system il macros)
:use-module (srfi srfi-16))
(define (make-label) (gensym ":L"))
(define (make-sym) (gensym "_"))
;;;
;;; Syntax
;;;
;; (@and X Y...) =>
;;
;; (@if X (@and Y...) #f)
(define @and
(case-lambda
(() #t)
((x) x)
((x . rest) `(@if ,x (@and ,@rest) #f))))
;; (@or X Y...) =>
;;
;; (@let ((@_ X)) (@if @_ @_ (@or Y...)))
(define @or
(case-lambda
(() #f)
((x) x)
((x . rest)
(let ((sym (make-sym)))
`(@let ((,sym ,x)) (@if ,sym ,sym (@or ,@rest)))))))
(define (@let* binds . body)
(if (null? binds)
`(@begin ,@body)
`(@let (,(car binds)) (@let* ,(cdr binds) ,@body))))
;;;
;;; R5RS Procedures
;;;
;; 6. Standard procedures
;;; 6.1 Equivalence predicates
(define (@eq? x y) `(@@ eq? ,x ,y))
;(define (@eqv? x y) `(@@ eqv? ,x ,y))
;(define (@equal? x y) `(@@ equal? ,x ,y))
;;; 6.2 Numbers
(define (@number? x) `((@ Core::number?) ,x))
(define (@complex? x) `((@ Core::complex?) ,x))
(define (@real? x) `((@ Core::real?) ,x))
(define (@rational? x) `((@ Core::rational?) ,x))
(define (@integer? x) `((@ Core::integer?) ,x))
(define (@exact? x) `((@ Core::exact?) ,x))
(define (@inexact? x) `((@ Core::inexact?) ,x))
;(define (@= x y) `(@@ ee? ,x ,y))
;(define (@< x y) `(@@ lt? ,x ,y))
;(define (@> x y) `(@@ gt? ,x ,y))
;(define (@<= x y) `(@@ le? ,x ,y))
;(define (@>= x y) `(@@ ge? ,x ,y))
(define @+
(case-lambda
(() 0)
((x) x)
((x y) `(@@ add ,x ,y))
((x y . rest) `(@@ add ,x (@+ ,y ,@rest)))))
(define @*
(case-lambda
(() 1)
((x) x)
((x y) `(@@ mul ,x ,y))
((x y . rest) `(@@ mul ,x (@* ,y ,@rest)))))
(define @-
(case-lambda
((x) `(@@ sub 0 ,x))
((x y) `(@@ sub ,x ,y))
((x y . rest) `(@@ sub ,x (@+ ,y ,@rest)))))
(define @/
(case-lambda
((x) `(@@ div 1 ,x))
((x y) `(@@ div ,x ,y))
((x y . rest) `(@@ div ,x (@* ,y ,@rest)))))
(define (@quotient x y) `(@@ quo ,x ,y))
(define (@remainder x y) `(@@ rem ,x ,y))
(define (@modulo x y) `(@@ mod ,x ,y))
;;; numerator
;;; denominator
;;;
;;; floor
;;; ceiling
;;; truncate
;;; round
;;;
;;; exp
;;; log
;;; sin
;;; cos
;;; tan
;;; asin
;;; acos
;;; atan
;;;
;;; sqrt
;;; expt
;;;
;;; make-rectangular
;;; make-polar
;;; real-part
;;; imag-part
;;; magnitude
;;; angle
;;;
;;; exact->inexact
;;; inexact->exact
;;;
;;; number->string
;;; string->number
;;; 6.3 Other data types
;;;; 6.3.1 Booleans
(define (@not x) `(@@ not ,x))
(define (@boolean? x) `((@ Core::boolean?) ,x))
;;;; 6.3.2 Pairs and lists
(define (@pair? x) `(@@ pair? ,x))
(define (@cons x y) `(@@ cons ,x ,y))
(define (@car x) `(@@ car ,x))
(define (@cdr x) `(@@ cdr ,x))
(define (@set-car! x y) `(@@ set-car! ,x ,y))
(define (@set-cdr! x y) `(@@ set-cdr! ,x ,y))
(define (@caar x) `(@@ car (@@ car ,x)))
(define (@cadr x) `(@@ car (@@ cdr ,x)))
(define (@cdar x) `(@@ cdr (@@ car ,x)))
(define (@cddr x) `(@@ cdr (@@ cdr ,x)))
(define (@caaar x) `(@@ car (@@ car (@@ car ,x))))
(define (@caadr x) `(@@ car (@@ car (@@ cdr ,x))))
(define (@cadar x) `(@@ car (@@ cdr (@@ car ,x))))
(define (@caddr x) `(@@ car (@@ cdr (@@ cdr ,x))))
(define (@cdaar x) `(@@ cdr (@@ car (@@ car ,x))))
(define (@cdadr x) `(@@ cdr (@@ car (@@ cdr ,x))))
(define (@cddar x) `(@@ cdr (@@ cdr (@@ car ,x))))
(define (@cdddr x) `(@@ cdr (@@ cdr (@@ cdr ,x))))
(define (@caaaar x) `(@@ car (@@ car (@@ car (@@ car ,x)))))
(define (@caaadr x) `(@@ car (@@ car (@@ car (@@ cdr ,x)))))
(define (@caadar x) `(@@ car (@@ car (@@ cdr (@@ car ,x)))))
(define (@caaddr x) `(@@ car (@@ car (@@ cdr (@@ cdr ,x)))))
(define (@cadaar x) `(@@ car (@@ cdr (@@ car (@@ car ,x)))))
(define (@cadadr x) `(@@ car (@@ cdr (@@ car (@@ cdr ,x)))))
(define (@caddar x) `(@@ car (@@ cdr (@@ cdr (@@ car ,x)))))
(define (@cadddr x) `(@@ car (@@ cdr (@@ cdr (@@ cdr ,x)))))
(define (@cdaaar x) `(@@ cdr (@@ car (@@ car (@@ car ,x)))))
(define (@cdaadr x) `(@@ cdr (@@ car (@@ car (@@ cdr ,x)))))
(define (@cdadar x) `(@@ cdr (@@ car (@@ cdr (@@ car ,x)))))
(define (@cdaddr x) `(@@ cdr (@@ car (@@ cdr (@@ cdr ,x)))))
(define (@cddaar x) `(@@ cdr (@@ cdr (@@ car (@@ car ,x)))))
(define (@cddadr x) `(@@ cdr (@@ cdr (@@ car (@@ cdr ,x)))))
(define (@cdddar x) `(@@ cdr (@@ cdr (@@ cdr (@@ car ,x)))))
(define (@cddddr x) `(@@ cdr (@@ cdr (@@ cdr (@@ cdr ,x)))))
(define (@null? x) `(@@ null? ,x))
(define (@list? x) `(@@ list? ,x))
(define (@list . args) `(@@ list ,@args))
;;; length
;;; append
;;; reverse
(define (@memq x l) `((@ Core::memq) ,x ,l))
(define (@memv x l) `((@ Core::memv) ,x ,l))
(define (@member x l) `((@ Core::member) ,x ,l))
(define (@assq x l) `((@ Core::assq) ,x ,l))
(define (@assv x l) `((@ Core::assv) ,x ,l))
(define (@assber x l) `((@ Core::assber) ,x ,l))
;;;; 6.3.3 Symbols
;;; symbol?
;;; symbol->string
;;; string->symbol
;;;; 6.3.4 Characters
;;; char?
;;; char=?
;;; char<?
;;; char>?
;;; char<=?
;;; char>=?
;;; char->integer
;;; integer->char
;;;; 6.3.5 Strings
;;; string?
;;; make-string
;;; string-length
;;; string-ref
;;; string-set!
;;;; 6.3.6 Vectors
;;; vector?
;;; make-vector
;;; vector-length
;;; vector-ref
;;; vector-set!
;;;; 6.4 Control features
(define (@procedure? x) `((@ Core::procedure?) ,x))
(define (@apply proc . args) `(@@ apply ,proc ,@args))
;;; (define (@force promise) `(@@ force promise))
;;; (define (@call/cc proc) `(@@ call/cc proc))
;;; values
;;; call-with-values
;;; dynamic-wind
;;; 6.5 Eval
;;; 6.6 Input and output
;;;; 6.6.1 Ports
;;; input-port?
;;; output-port?
;;; current-input-port
;;; current-output-port
;;;
;;; open-input-file
;;; open-output-file
;;; close-input-port
;;; close-output-port
;;;; 6.6.2 Input
;;; read
;;; read-char
;;; peek-char
;;; eof-object?
;;; char-ready?
;;;; 6.6.3 Output
;;; write
;;; display
;;; newline
;;; write-char
;;;; 6.6.4 System interface
;;;
;;; Non-R5RS Procedures
;;;
(define @cons*
(case-lambda
((x) x)
((x y) `(@cons ,x ,y))
((x y . rest) `(@cons ,x (@cons* ,y ,@rest)))))

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

@ -27,6 +27,7 @@
:use-module (system repl common)
:use-module (system repl command)
:use-module (system vm core)
:use-module (system vm debug)
:use-module (ice-9 rdelim)
:export (start-repl))
@ -61,6 +62,7 @@
((vm-error ,fun ,msg ,args)
(display "VM error: ")
(apply format #t msg args)
(vm-backtrace (the-vm))
(newline))
((,key ,subr ,msg ,args . ,rest)
(let ((cep (current-error-port)))

2
module/system/vm/Makefile.am
View file

@ -1,4 +1,4 @@
SOURCES = assemble.scm conv.scm core.scm debug.scm \
SOURCES = assemble.scm bootstrap.scm conv.scm core.scm debug.scm \
disasm.scm frame.scm profile.scm trace.scm
moddir = $(guiledir)/system/vm
include $(top_srcdir)/guilec.mk

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

@ -30,6 +30,7 @@
:use-module (ice-9 regex)
:use-module (ice-9 common-list)
:use-module (srfi srfi-4)
:use-module ((srfi srfi-1) :select (append-map))
:export (preprocess codegen assemble))
(define (assemble glil env . opts)
@ -214,9 +215,8 @@
(define (stack->bytes stack label-alist)
(let loop ((result '()) (stack stack) (addr 0))
(if (null? stack)
(apply u8vector
(apply append
(map u8vector->list (reverse! result))))
(list->u8vector(append-map u8vector->list
(reverse! result)))
(let ((bytes (car stack)))
(if (pair? bytes)
(let* ((offset (- (assq-ref label-alist (cadr bytes))

39
module/system/vm/bootstrap.scm Normal file
View file

@ -0,0 +1,39 @@
;;; Bootstrapping the VM into the interpreter
;; 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 (system vm bootstrap))
;;;
;;; Core procedures
;;;
(dynamic-call "scm_init_vm" (dynamic-link "libguile-vm"))
(module-export! (current-module)
(delq! '%module-public-interface
(hash-fold (lambda (k v d) (cons k d)) '()
(module-obarray (current-module)))))
;; `load-compiled' is referred to by `boot-9.scm' and used by `use-modules'
;; and friends.
(set! load-compiled
(lambda (file)
((the-vm) (objcode->program (load-objcode file)))))

14
module/system/vm/core.scm
View file

@ -20,6 +20,7 @@
;;; Code:
(define-module (system vm core)
:use-module (system vm bootstrap)
:export (arity:nargs arity:nrest arity:nlocs arity:nexts
make-binding binding:name binding:extp binding:index
program-bindings program-sources
@ -34,12 +35,11 @@
;;; Core procedures
;;;
(dynamic-call "scm_init_vm" (dynamic-link "libguile-vm"))
(module-export! (current-module)
(delq! '%module-public-interface
;; FIXME
(module-re-export! (current-module)
(hash-fold (lambda (k v d) (cons k d)) '()
(module-obarray (current-module)))))
(module-obarray
(resolve-interface '(system vm bootstrap)))))
;;;
@ -171,7 +171,3 @@
(define (vm-load vm objcode)
(vm (objcode->program objcode)))
;; `load-compiled' is referred to by `boot-9.scm' and used by `use-modules'
;; and friends.
(set! load-compiled (lambda (file) (vm-load (the-vm) (load-objcode file))))

6
module/system/vm/frame.scm
View file

@ -43,10 +43,10 @@
(let* ((link (vm:frame-dynamic-link frame))
(chain (if (eq? link #t)
'()
(cons frame (vm:make-frame-chain
(cons frame (make-frame-chain
link (vm:frame-return-address frame))))))
(set! (vm:frame-number frame) (length chain))
(set! (vm:frame-address frame)
(set! (frame-number frame) (length chain))
(set! (frame-address frame)
(- addr (program-base (vm:frame-program frame))))
chain))

3
src/guilec.in
View file

@ -20,7 +20,8 @@
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
(use-modules (system base compile)
(use-modules (system vm bootstrap)
(system base compile)
(ice-9 getopt-long))
(read-set! keywords 'prefix)

4
src/vm.c
View file

@ -54,8 +54,8 @@
/* I sometimes use this for debugging. */
#define vm_puts(OBJ) \
{ \
scm_display (OBJ, scm_def_errp); \
scm_newline (scm_def_errp); \
scm_display (OBJ, scm_current_error_port ()); \
scm_newline (scm_current_error_port ()); \
}