diff --git a/README b/README index f7a79bd4c..3e05b6962 100644 --- a/README +++ b/README @@ -7,10 +7,12 @@ Installation % configure % make install - % ln -s module/{system,language} /usr/local/share/guile/site/ + % ln -s module/{guile,system,language} /usr/local/share/guile/ 3. Add the following lines to your ~/.guile: + (use-modules (system vm core) + (cond ((string=? (car (command-line)) "guile-vm") (use-modules (system repl repl)) (start-repl 'scheme) @@ -20,79 +22,63 @@ Example Session --------------- % guile-vm - Guile Scheme interpreter 0.4 on Guile 1.4.1 + Guile Scheme interpreter 0.5 on Guile 1.4.1 Copyright (C) 2001 Free Software Foundation, Inc. Enter `,help' for help. - gscheme@guile> (+ 1 2) - $1 = 3 - gscheme@guile> ,c -c (+ 1 2) ;; Compile into GLIL - (@asm (0 0 0 0) + scheme@guile-user> (+ 1 2) + 3 + scheme@guile-user> ,c -c (+ 1 2) ;; Compile into GLIL + (@asm (0 1 0 0) + (module-ref #f +) (const 1) (const 2) - (add 2) - (return 0)) - gscheme@guile> ,c (+ 1 2) ;; Compile into bootcode - Disassembly of bootcode: - - Compiled for Guile VM 0.4 + (tail-call 2)) + scheme@guile-user> ,c (+ 1 2) ;; Compile into object code + Disassembly of #: nlocs = 0 nexts = 0 - 0 make-int8:1 ;; 1 - 1 make-int8 2 ;; 2 - 3 add - 4 return + 0 link "+" ;; (+ . ???) + 3 variable-ref + 4 make-int8:1 ;; 1 + 5 make-int8 2 ;; 2 + 7 tail-call 2 - gscheme@guile> (define (add x y) (+ x y)) - gscheme@guile> (add 1 2) - $2 = 3 - gscheme@guile> ,x add ;; Disassemble + scheme@guile-user> (define (add x y) (+ x y)) + scheme@guile-user> (add 1 2) + 3 + scheme@guile-user> ,x add ;; Disassemble Disassembly of #: nargs = 2 nrest = 0 nlocs = 0 nexts = 0 Bytecode: - 0 local-ref 0 - 2 local-ref 1 - 4 add - 5 return + 0 object-ref 0 ;; (+ . #) + 2 variable-ref + 3 local-ref 0 + 5 local-ref 1 + 7 tail-call 2 - gscheme@guile> + Objects: -Write Modules -------------- + 0 (+ . #) - ---- fib.scm --------------------------- - (define-module (fib) - :use-module (system vm load) - :export (fib)) + scheme@guile-user> - (load/compile "fib.gs") - ---------------------------------------- +Compile Modules +--------------- - ---- fib.gs ---------------------------- - (define (fib n) - (if (< n 2) - 1 - (+ (fib (- n 1)) (fib (- n 2))))) - ---------------------------------------- +Use `guilec' to compile your modules: -Now, expressions in fib.gsm are automatically compiled and -executed by the Guile VM: + % cat fib.scm + (define-module (fib) :export (fib)) + (define (fib n) (if (< n 2) 1 (+ (fib (- n 1)) (fib (- n 2))))) + % guilec fib.scm + Wrote fib.go % guile guile> (use-modules (fib)) - guile> (time (fib 30)) - clock utime stime cutime cstime gctime - 2.80 2.79 0.00 0.00 0.00 0.00 - $1 = 1346269 - guile> (define (fib n) (if (< n 2) 1 (+ (fib (- n 1)) (fib (- n 2))))) - guile> (time (fib 30)) - clock utime stime cutime cstime gctime - 26.05 25.01 0.17 0.00 0.00 14.33 - $2 = 1346269 - -If you don't want to compile your code (e.g., for debugging purpose), -just change `load/compile' to `load'. + guile> (fib 8) + 34 diff --git a/configure.in b/configure.in index 69f52bbd1..d82bb532e 100644 --- a/configure.in +++ b/configure.in @@ -12,4 +12,4 @@ AC_PROG_LN_S AM_PROG_LIBTOOL AC_C_LABELS_AS_VALUES -AC_OUTPUT(Makefile src/Makefile doc/Makefile module/Makefile src/guilec) +AC_OUTPUT(Makefile src/Makefile doc/Makefile module/Makefile) diff --git a/module/Makefile.am b/module/Makefile.am index 0e2b9dfcd..4c26fc3e2 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -1,5 +1,5 @@ -DISTDIRS = $(srcdir)/language $(srcdir)/system $(srcdir)/slib -EXCLUDES = --exclude=CVS --exclude='*~' +DISTDIRS = $(srcdir)/system $(srcdir)/language $(srcdir)/guile $(srcdir)/slib +EXCLUDES = --exclude=CVS --exclude=*.go --exclude=*~ all: slibcat @@ -7,7 +7,7 @@ clean: rm -f slibcat slib/*.go slibcat: - guile -s slib-comp.scm + guile -s $(top_srcdir)/src/guilec slib/*.scm dist-hook: $(TAR) cf - $(EXCLUDES) $(DISTDIRS) | (cd $(distdir); $(TAR) xf -) diff --git a/module/language/scheme/spec.scm b/module/language/scheme/spec.scm index d0281512b..765a70009 100644 --- a/module/language/scheme/spec.scm +++ b/module/language/scheme/spec.scm @@ -30,15 +30,11 @@ (read-enable 'positions) -;;; -;;; Compiler -;;; - -(define (compile port env . opts) +(define (read-file port) (do ((x (read port) (read port)) (l '() (cons x l))) ((eof-object? x) - (apply compile-in (cons 'begin (reverse! l)) env scheme opts)))) + (cons 'begin (reverse! l))))) ;;; ;;; Language definition @@ -48,7 +44,7 @@ :title "Guile Scheme" :version "0.5" :reader read + :read-file read-file :translator translate :printer write - :compiler compile ) diff --git a/module/language/scheme/translate.scm b/module/language/scheme/translate.scm index 5b3585b08..f13040314 100644 --- a/module/language/scheme/translate.scm +++ b/module/language/scheme/translate.scm @@ -36,6 +36,9 @@ ;;; Translator ;;; +(define scheme-primitives + '(not null? eq? eqv? equal? pair? list? cons car cdr set-car! set-cdr!)) + (define (trans e l x) (cond ((pair? x) (let ((y (macroexpand x))) @@ -216,15 +219,17 @@ (() (make:void)) ((('else . body)) (trans:pair `(begin ,@body))) (((((? symbol? key) ...) body ...) rest ...) - (if (memq 'compile key) - (primitive-eval `(begin ,@(copy-tree body)))) (if (memq 'load-toplevel key) - (trans:pair `(begin ,@body)) + (begin + (primitive-eval `(begin ,@(copy-tree body))) + (trans:pair `(begin ,@body))) (loop rest))) (else (bad-syntax))))) (else - (make- e l (trans:x head) (map trans:x tail))))) + (if (memq head scheme-primitives) + (make- e l head (map trans:x tail)) + (make- e l (trans:x head) (map trans:x tail)))))) (define (trans-quasiquote e l x) (cond ((not (pair? x)) x) diff --git a/module/slib/guile.init b/module/slib/guile.init index 2d53c5d59..167988352 100644 --- a/module/slib/guile.init +++ b/module/slib/guile.init @@ -223,10 +223,10 @@ ;;; by compiling "foo.scm" if this implementation can compile files. ;;; See feature 'COMPILED. -(define slib:load-compiled load-compiled) +(define (slib:load-compiled f) (load-compiled-file (string-append f ".go"))) ;;; At this point SLIB:LOAD must be able to load SLIB files. -(define slib:load slib:load-compiled) +(define slib:load slib:load) (slib:load (in-vicinity (library-vicinity) "require")) diff --git a/module/system/base/.cvsignore b/module/system/base/.cvsignore new file mode 100644 index 000000000..e796b66a8 --- /dev/null +++ b/module/system/base/.cvsignore @@ -0,0 +1 @@ +*.go diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm index 686931948..32c36c892 100644 --- a/module/system/base/compile.scm +++ b/module/system/base/compile.scm @@ -20,29 +20,125 @@ ;;; Code: (define-module (system base compile) + :use-module (oop goops) + :use-syntax (system base syntax) :use-module (system base language) - :use-module (ice-9 regex) - :export (compile-file object-file-name)) + :use-module (system il compile) + :use-module (system vm core) + :use-module (system vm assemble) + :use-module (ice-9 regex)) + +;;; +;;; Compiler environment +;;; + +(define-vm-class () + vm language module optimize) + +(define-public (make-cenv . rest) + (apply make rest)) + +(define-public (syntax-error loc msg exp) + (throw 'syntax-error loc msg exp)) + +(define-public (call-with-compile-error-catch thunk) + (catch 'syntax-error + thunk + (lambda (key loc msg exp) + (format #t "~A:~A: ~A: ~A" (car loc) (cdr loc) msg exp)))) + + +;;; +;;; Compiler +;;; (define scheme (lookup-language 'scheme)) -(define (compile-file file) - (let ((comp (object-file-name file))) - (call-with-compile-error-catch - (lambda () - (catch #t +(define-public (compile-file file . opts) + (let ((comp (compiled-file-name file))) + (catch #t + (lambda () + (call-with-compile-error-catch (lambda () (call-with-output-file comp (lambda (port) - (uniform-array-write (compile-file-in file scheme) port)))) - (lambda (key . args) - (format #t "ERROR: In ~A:\n" file) - (display "ERROR: ") - (format #t (cadr args) (caddr args)) - (newline) - (delete-file comp))))) - (format #t "Wrote ~A\n" comp))) + (let* ((source (read-file-in file scheme)) + (objcode (apply compile-in source (current-module) + scheme opts))) + (uniform-array-write (objcode->string objcode) port)))) + (format #t "Wrote ~A\n" comp)))) + (lambda (key . args) + (format #t "ERROR: In ~A:\n" file) + (display "ERROR: ") + (format #t (cadr args) (caddr args)) + (newline) + (delete-file comp))))) -(define (object-file-name file) +(define-public (load-source-file file . opts) + (let ((source (read-file-in file scheme))) + (vm-load (the-vm) (apply compile-in source (current-module) scheme opts)))) + +(define-public (load-file file . opts) + (let ((comp (compiled-file-name file))) + (if (file-exists? comp) + (vm-load (the-vm) (load-objcode comp)) + (apply load-source-file file opts)))) + +(define-public (compiled-file-name file) (let ((m (string-match "\\.[^.]*$" file))) (string-append (if m (match:prefix m) file) ".go"))) + + +;;; +;;; Scheme compiler interface +;;; + +(define-public (read-file-in file lang) + (call-with-input-file file lang.read-file)) + +(define-public (compile-in x e lang . opts) + (catch 'result + (lambda () + ;; expand + (set! x (lang.expander x e)) + (if (memq :e opts) (throw 'result x)) + ;; translate + (set! x (lang.translator x e)) + (if (memq :t opts) (throw 'result x)) + ;; compile + (set! x (apply compile x e opts)) + (if (memq :c opts) (throw 'result x)) + ;; assemble + (apply assemble x e opts)) + (lambda (key val) val))) + +;;; +;;; +;;; + +(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))) diff --git a/module/system/base/language.scm b/module/system/base/language.scm index 83014584e..5ac1eb3ee 100644 --- a/module/system/base/language.scm +++ b/module/system/base/language.scm @@ -22,12 +22,7 @@ (define-module (system base language) :use-module (oop goops) :use-syntax (system base syntax) - :use-module (system il compile) - :use-module (system vm core) - :use-module (system vm assemble) - :use-module (ice-9 regex) - :export (define-language lookup-language read-in compile-in print-in - compile-file-in)) + :export (define-language lookup-language)) ;;; @@ -36,12 +31,10 @@ (define-vm-class () name title version environment - (reader) + reader printer read-file (expander (lambda (x e) x)) (translator (lambda (x e) x)) (evaluator #f) - (printer) - (compiler) ) (define-method (write (lang ) port) @@ -57,43 +50,3 @@ (if (module-bound? m name) (module-ref m name) (error "No such language:" name)))) - - -;;; -;;; Evaluation interface -;;; - -(define (read-in lang . port) - (lang.reader (if (null? port) (current-input-port) (car port)))) - -(define (compile-in x e lang . opts) - (catch 'result - (lambda () - ;; expand - (set! x (lang.expander x e)) - (if (memq :e opts) (throw 'result x)) - ;; translate - (set! x (lang.translator x e)) - (if (memq :t opts) (throw 'result x)) - ;; compile - (set! x (apply compile x e opts)) - (if (memq :c opts) (throw 'result x)) - ;; assemble - (apply assemble x e opts)) - (lambda (key val) val))) - -(define (print-in val lang . port) - (lang.printer val (if (null? port) (current-output-port) (car port)))) - -(define (compile-file-in file lang . opts) - (call-with-input-file file - (lambda (port) (apply lang.compiler port (current-module) opts)))) - -(define-public (syntax-error loc msg exp) - (throw 'syntax-error loc msg exp)) - -(define-public (call-with-compile-error-catch thunk) - (catch 'syntax-error - thunk - (lambda (key loc msg exp) - (format #t "~A:~A: ~A: ~A" (car loc) (cdr loc) msg exp)))) diff --git a/module/system/il/.cvsignore b/module/system/il/.cvsignore new file mode 100644 index 000000000..e796b66a8 --- /dev/null +++ b/module/system/il/.cvsignore @@ -0,0 +1 @@ +*.go diff --git a/module/system/repl/.cvsignore b/module/system/repl/.cvsignore new file mode 100644 index 000000000..e796b66a8 --- /dev/null +++ b/module/system/repl/.cvsignore @@ -0,0 +1 @@ +*.go diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm index c665499d1..1d374722a 100644 --- a/module/system/repl/command.scm +++ b/module/system/repl/command.scm @@ -21,37 +21,31 @@ (define-module (system repl command) :use-syntax (system base syntax) - :use-module (system base language) + :use-module (system base compile) :use-module (system repl common) - :use-module (system il glil) :use-module (system vm core) + :autoload (system il glil) (pprint-glil) + :autoload (system vm disasm) (disassemble-program disassemble-objcode) :autoload (system vm trace) (vm-trace) - :autoload (system vm disasm) (disassemble-program disassemble-dumpcode) :autoload (system vm profile) (vm-profile) :use-module (ice-9 format) :use-module (ice-9 session) - :export (meta-command)) - -(define (puts x) (display x) (newline)) - -(define (user-error msg . args) - (throw 'user-error #f msg args #f)) + :use-module (ice-9 documentation)) ;;; -;;; Meta command +;;; Meta command interface ;;; (define *command-table* '((help (help h) (apropos a) (describe d) (option o) (quit q)) - (module (module m) (use u) (import i) (load l) (binding b) (lsmod lm)) - (package (package p) (lspkg lp) (autopackage) (globals g)) + (module (module m) (use u) (import i) (load l) (binding b)) (language (language L)) (compile (compile c) (compile-file cc) (disassemble x) (disassemble-file xx)) (profile (time t) (profile pr)) - (debug (backtrace bt) (debugger db) (trace tr) (step st)) - (system (statistics stat) (gc)))) + (debug (backtrace bt) (debugger db) (trace r) (step st)) + (system (gc) (statistics st)))) (define (group-name g) (car g)) (define (group-commands g) (cdr g)) @@ -102,7 +96,7 @@ (let ((abbrev (if abbrev (format #f "[,~A]" abbrev) ""))) (format #t " ,~24A ~8@A - ~A\n" usage abbrev summary))) -(define (meta-command repl line) +(define-public (meta-command repl line) (let ((input (call-with-input-string (string-append "(" line ")") read))) (if (not (null? input)) (do ((key (car input)) @@ -125,10 +119,10 @@ (define (help repl . args) "help [GROUP] -Show help messages. -The optional argument can be either one of command groups or -command names. Without argument, a list of help commands and -all command groups are displayed, as you have already seen :)" +List available meta commands. +A command group name can be given as an optional argument. +Without any argument, a list of help commands and command groups +are displayed, as you have already seen ;)" (match args (() (display-group (lookup-group 'help)) @@ -141,27 +135,29 @@ all command groups are displayed, as you have already seen :)" (display-summary usage #f header))) (cdr *command-table*)) (newline) - (display "Enter `,COMMAND -h' to display documentation of each command.") + (display "Type `,COMMAND -h' to show documentation of each command.") (newline)) (('all) (for-each display-group *command-table*)) ((? lookup-group group) (display-group (lookup-group group))) - (else (user-error "Unknown command group: ~A" (car args))))) + (else + (user-error "Unknown command group: ~A" (car args))))) -(define guile-apropos apropos) +(define guile:apropos apropos) (define (apropos repl regexp) - "apropos [options] REGEXP + "apropos REGEXP Find bindings/modules/packages." - (guile-apropos (object->string regexp display))) + (guile:apropos (->string regexp))) (define (describe repl obj) "describe OBJ Show description/documentation." - (display "Not implemented yet\n")) + (display (object-documentation (repl-eval repl obj))) + (newline)) (define (option repl . args) - "option [KEY [VALUE]] + "option [KEY VALUE] List/show/set options." (display "Not implemented yet\n")) @@ -179,7 +175,7 @@ Quit this session." "module [MODULE] Change modules / Show current module." (match args - (() (puts (binding repl.module))))) + (() (puts (binding repl.env.module))))) (define (use repl . args) "use [MODULE ...] @@ -187,11 +183,12 @@ Use modules." (define (use name) (let ((mod (resolve-interface name))) (if mod - (module-use! repl.module mod) + (module-use! repl.env.module mod) (user-error "No such module: ~A" name)))) (if (null? args) (for-each puts (map module-name - (cons repl.module (module-uses repl.module)))) + (cons repl.env.module + (module-uses repl.env.module)))) (for-each (lambda (name) (cond ((pair? name) (use name)) @@ -206,11 +203,11 @@ Import modules / List those imported." (define (use name) (let ((mod (resolve-interface name))) (if mod - (module-use! repl.module mod) + (module-use! repl.env.module mod) (user-error "No such module: ~A" name)))) (if (null? args) (for-each puts (map module-name - (cons repl.module (module-uses repl.module)))) + (cons repl.env.module (module-uses repl.env.module)))) (for-each (lambda (name) (cond ((pair? name) (use name)) @@ -221,55 +218,23 @@ Import modules / List those imported." args))) (define (load repl file . opts) - "load [options] FILE -Load a file in the current module." - (apply repl-load-file repl (->string file) opts)) + "load FILE +Load a file in the current module. + + -f Load source file (see `compile') + -r Trace loading (see `trace')" + (let* ((file (->string file)) + (objcode (if (memq :f opts) + (apply load-source-file file opts) + (apply load-file file opts)))) + (if (memq :r opts) + (apply vm-trace repl.env.vm objcode opts) + (vm-load repl.env.vm objcode)))) (define (binding repl . opts) - "binding [-a] + "binding List current bindings." - (fold (lambda (s v d) (format #t "~23A ~A\n" s v)) #f repl.module)) - -(define (lsmod repl . args) - "lsmod -." - (define (use name) - (set! repl.module (resolve-module name)) - (module-use! repl.module repl.value-history)) - (if (null? args) - (use '(guile-user)) - (let ((name (car args))) - (cond - ((pair? name) (use name)) - ((symbol? name) - (and-let* ((m (find-one-module (symbol->string name)))) - (puts m) (use m))) - (else (user-error "Invalid module name: ~A" name)))))) - - -;;; -;;; Package commands -;;; - -(define (package repl) - "package [PACKAGE] -List available packages/modules." - (for-each puts (find-module ""))) - -(define (lspkg repl) - "lspkg -List available packages/modules." - (for-each puts (find-module ""))) - -(define (autopackage repl) - "autopackage -List available packages/modules." - (for-each puts (find-module ""))) - -(define (globals repl) - "globals -List all global variables." - (global-fold (lambda (s v d) (format #t "~A\t~S\n" s v)) #f)) + (fold (lambda (s v d) (format #t "~23A ~A\n" s v)) #f repl.env.module)) ;;; @@ -279,7 +244,7 @@ List all global variables." (define (language repl name) "language LANGUAGE Change languages." - (set! repl.language (lookup-language name)) + (set! repl.env.language (lookup-language name)) (repl-welcome repl)) @@ -288,7 +253,7 @@ Change languages." ;;; (define (compile repl form . opts) - "compile [options] FORM + "compile FORM Generate compiled code. -e Stop after expanding syntax/macro @@ -300,10 +265,10 @@ Generate compiled code. (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-dumpcode x))))) + (else (disassemble-objcode x))))) (define (compile-file repl file . opts) - "compile-file [options] FILE + "compile-file FILE Compile a file." (apply repl-compile-file repl (->string file) opts)) @@ -315,31 +280,51 @@ Disassemble a program." (define (disassemble-file repl file) "disassemble-file FILE Disassemble a file." - (disassemble-dumpcode (load-dumpcode (->string file)))) - -(define (->string x) - (object->string x display)) + (disassemble-objcode (load-objcode (->string file)))) ;;; ;;; Profile commands ;;; +(define (time repl form) + "time FORM +Time execution." + (let* ((vms-start (vm-stats repl.env.vm)) + (gc-start (gc-run-time)) + (tms-start (times)) + (result (repl-eval repl form)) + (tms-end (times)) + (gc-end (gc-run-time)) + (vms-end (vm-stats repl.env.vm))) + (define (get proc start end) + (/ (- (proc end) (proc start)) internal-time-units-per-second)) + (repl-print repl result) + (display "clock utime stime cutime cstime gctime\n") + (format #t "~5,2F ~5,2F ~5,2F ~6,2F ~6,2F ~6,2F\n" + (get tms:clock tms-start tms-end) + (get tms:utime tms-start tms-end) + (get tms:stime tms-start tms-end) + (get tms:cutime tms-start tms-end) + (get tms:cstime tms-start tms-end) + (get identity gc-start gc-end)) + result)) + (define (profile repl form . opts) "profile FORM Profile execution." - (apply vm-profile repl.vm (repl-compile repl form) opts)) + (apply vm-profile repl.env.vm (repl-compile repl form) opts)) ;;; ;;; Debug commands ;;; -(define guile-backtrace backtrace) +(define guile:backtrace backtrace) (define (backtrace repl) "backtrace Show backtrace (if any)." - (guile-backtrace)) + (guile:backtrace)) (define (debugger repl) "debugger @@ -347,9 +332,14 @@ Start debugger." (debug)) (define (trace repl form . opts) - "trace [-b] FORM -Trace execution." - (apply vm-trace repl.vm (repl-compile repl form) opts)) + "trace FORM +Trace execution. + + -s Display stack + -l Display local variables + -e Display external variables + -b Bytecode level trace" + (apply vm-trace repl.env.vm (repl-compile repl form) opts)) (define (step repl) "step FORM @@ -361,44 +351,17 @@ Step execution." ;;; System commands ;;; -(define (time repl form) - "time FORM -Time execution." - (let* ((vms-start (vm-stats repl.vm)) - (gc-start (gc-run-time)) - (tms-start (times)) - (result (repl-eval repl form)) - (tms-end (times)) - (gc-end (gc-run-time)) - (vms-end (vm-stats repl.vm))) - (define (get proc start end) - (/ (- (proc end) (proc start)) internal-time-units-per-second)) - (repl-print repl result) - (display "clock utime stime cutime cstime gctime\n") - (format #t "~5,2F ~5,2F ~5,2F ~6,2F ~6,2F ~6,2F\n" - (get tms:clock tms-start tms-end) - (get tms:utime tms-start tms-end) - (get tms:stime tms-start tms-end) - (get tms:cutime tms-start tms-end) - (get tms:cstime tms-start tms-end) - (get id gc-start gc-end)) - result)) - -(define guile-gc gc) +(define guile:gc gc) (define (gc repl) "gc Garbage collection." - (guile-gc)) - -;;; -;;; Statistics -;;; + (guile:gc)) (define (statistics repl) "statistics Display statistics." (let ((this-tms (times)) - (this-vms (vm-stats repl.vm)) + (this-vms (vm-stats repl.env.vm)) (this-gcs (gc-stats)) (last-tms repl.tm-stats) (last-vms repl.vm-stats) diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm index 651bd5205..4bd8986a9 100644 --- a/module/system/repl/common.scm +++ b/module/system/repl/common.scm @@ -22,70 +22,66 @@ (define-module (system repl common) :use-module (oop goops) :use-syntax (system base syntax) + :use-module (system base compile) :use-module (system base language) :use-module (system vm core) - :use-module (system vm trace) - :export (make-repl repl-welcome repl-prompt repl-read repl-compile - repl-eval repl-print repl-compile-file repl-load-file)) + :use-module (system vm trace)) ;;; -;;; Repl +;;; Repl type ;;; -(define-vm-class () - vm language module value-count value-history tm-stats vm-stats gc-stats) +(define-vm-class () env tm-stats vm-stats gc-stats) -(define (make-repl lang) - (let ((vm (the-vm))) +(define-public (make-repl lang) + (let ((cenv (make-cenv :vm (the-vm) + :language (lookup-language lang) + :module (current-module)))) (make - :vm vm - :language (lookup-language lang) - :module (current-module) ;; (global-ref 'user) - :value-count 0 -; :value-history (make-vmodule) + :env cenv :tm-stats (times) - :vm-stats (vm-stats vm) + :vm-stats (vm-stats cenv.vm) :gc-stats (gc-stats)))) -(define (repl-welcome repl) +(define-public (repl-welcome repl) (format #t "~A interpreter ~A on Guile ~A\n" - repl.language.title repl.language.version (version)) + repl.env.language.title repl.env.language.version (version)) (display "Copyright (C) 2001 Free Software Foundation, Inc.\n\n") (display "Enter `,help' for help.\n")) -(define (repl-prompt repl) - (format #t "~A@~A> " repl.language.name 'guile) - ;; (env-identifier repl.module)) - (force-output)) +(define-public (repl-prompt repl) + (let ((module-name (car (last-pair (module-name repl.env.module))))) + (format #t "~A@~A> " repl.env.language.name module-name) + (force-output))) -(define (repl-read repl . args) - (apply read-in repl.language args)) +(define-public (repl-read repl) + (repl.env.language.reader)) -(define (repl-compile repl form . opts) - (apply compile-in form repl.module repl.language opts)) +(define-public (repl-compile repl form . opts) + (apply compile-in form repl.env.module repl.env.language opts)) -(define (repl-eval repl form) - (let ((eval repl.language.evaluator)) +(define-public (repl-eval repl form) + (let ((eval repl.env.language.evaluator)) (if eval - (eval form repl.module) - (vm-load repl.vm (repl-compile repl form))))) + (eval form repl.env.module) + (vm-load repl.env.vm (repl-compile repl form))))) -(define (repl-print repl val) +(define-public (repl-print repl val) (if (not (eq? val *unspecified*)) - (let* ((num (1+ repl.value-count)) - (sym (string->symbol (format #f "$~A" num)))) -; (vmodule-define repl.value-history sym val) - (format #t "~A = " sym) - (print-in val repl.language) - (newline) - (set! repl.value-count num)))) + (begin + (repl.env.language.printer val) + (newline)))) -(define (repl-compile-file repl file . opts) - (apply compile-file-in file repl.language opts)) + +;;; +;;; Utilities +;;; -(define (repl-load-file repl file . opts) - (let ((bytes (apply repl-compile-file repl file opts))) - (if (or (memq :b opts) (memq :r opts)) - (apply vm-trace repl.vm bytes opts) - (vm-load repl.vm bytes)))) +(define-public (puts x) (display x) (newline)) + +(define-public (->string x) + (object->string x display)) + +(define-public (user-error msg . args) + (throw 'user-error #f msg args #f)) diff --git a/module/system/repl/describe.scm b/module/system/repl/describe.scm index 966ea7d46..15f0b0b04 100644 --- a/module/system/repl/describe.scm +++ b/module/system/repl/describe.scm @@ -22,16 +22,15 @@ (define-module (system repl describe) :use-module (oop goops) :use-module (ice-9 regex) - :use-module (ice-9 format)) + :use-module (ice-9 format) + :use-module (ice-9 and-let-star) + :export (describe)) -(define *describe-format* #t) - -(define-public (describe symbol) - (assert symbol? symbol) +(define-method (describe (symbol )) (format #t "`~s' is " symbol) (if (not (defined? symbol)) (display "not defined in the current module.\n") - (describe-object (eval symbol)))) + (describe-object (module-ref (current-module) symbol)))) ;;; @@ -302,13 +301,13 @@ ;;; Instances ;;; -(define-method display-type ((obj )) +(define-method (display-type (obj )) (display-class "an instance") (display " of class ") (display-class (class-of obj)) (display ".\n")) -(define-method display-value ((obj )) +(define-method (display-value (obj )) (display-slot-list #f obj (class-slots (class-of obj)))) @@ -316,13 +315,13 @@ ;;; Generic functions ;;; -(define-method display-type ((obj )) +(define-method (display-type (obj )) (display-class "a generic function") (display " of class ") (display-class (class-of obj)) (display ".\n")) -(define-method display-value ((obj )) +(define-method (display-value (obj )) (display-list #f (generic-function-methods obj))) diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm index 5c01c8b3a..73473af8c 100644 --- a/module/system/repl/repl.scm +++ b/module/system/repl/repl.scm @@ -23,14 +23,11 @@ :use-syntax (system base syntax) :use-module (system repl common) :use-module (system repl command) - :use-module (system vm frame) :use-module (ice-9 rdelim) :export (start-repl)) (define (start-repl lang) (let ((repl (make-repl lang))) -;; (set-current-vmodule! repl.module) -;; (set-current-evaluator! repl.vm) (repl-welcome repl) (let prompt-loop () (repl-prompt repl) @@ -38,8 +35,7 @@ (lambda () (if (eq? (next-char #t) #\,) ;; meta command - (begin (read-char) - (meta-command repl (read-line))) + (begin (read-char) (meta-command repl (read-line))) ;; evaluation (let rep-loop () (repl-print repl (repl-eval repl (repl-read repl))) diff --git a/module/system/vm/assemble.scm b/module/system/vm/assemble.scm index 7cd8c1dd4..1e9e2d6f8 100644 --- a/module/system/vm/assemble.scm +++ b/module/system/vm/assemble.scm @@ -146,7 +146,7 @@ (for-each generate-code body) (let ((bytes (stack->bytes (reverse! stack) label-alist))) (if toplevel - (make-dumpcode nlocs nexts bytes) + (bytecode->objcode bytes nlocs nexts) (let ((objs (map car (reverse! object-alist)))) (make-bytespec nargs nrest nlocs nexts bytes objs (venv-closure? venv))))))))) diff --git a/module/system/vm/conv.scm b/module/system/vm/conv.scm index a21d1c843..5e246eb96 100644 --- a/module/system/vm/conv.scm +++ b/module/system/vm/conv.scm @@ -83,7 +83,7 @@ (('load-string s) s) (('load-symbol s) (string->symbol s)) (('load-keyword s) (make-keyword-from-dash-symbol (string->symbol s))) - (('link s) (string->symbol s)) + (('link s) (cons (string->symbol s) '???)) (else #f))) (define (code->bytes code) diff --git a/module/system/vm/core.scm b/module/system/vm/core.scm index 87810c914..a5679d08b 100644 --- a/module/system/vm/core.scm +++ b/module/system/vm/core.scm @@ -21,6 +21,7 @@ (define-module (system vm core)) + ;;; ;;; Core procedures ;;; @@ -32,60 +33,37 @@ (hash-fold (lambda (k v d) (cons k d)) '() (module-obarray (current-module))))) + ;;; -;;; Dumpcode interface +;;; Loader ;;; -(export make-dumpcode dumpcode? dumpcode-version - dumpcode-nlocs dumpcode-nexts dumpcode-bytecode - load-dumpcode save-dumpcode) +(define-public (vm-load vm objcode) + (vm (objcode->program objcode))) -(define *dumpcode-cookie* (string-append "\0GBC-" (vm-version))) +(set! load-compiled (lambda (file) (vm-load (the-vm) (load-objcode file)))) -(define (make-dumpcode nlocs nexts bytes) - (string-append *dumpcode-cookie* - (integer->bytes nlocs) - (integer->bytes nexts) - bytes)) + +;;; +;;; Frame interface +;;; -(define (dumpcode? x) - (and (string? x) - (> (string-length x) 10) - (string=? (substring x 1 4) "GBC"))) +(define-public (frame->call frame) + (let* ((prog (frame-program frame)) + (nargs (car (program-arity prog)))) + (do ((i 0 (1+ i)) + (l (vector->list (frame-variables frame)) (cdr l)) + (r '() (cons (car l) r))) + ((= i nargs) (cons (program-name prog) (reverse! r)))))) -(define (dumpcode-version x) - (substring x 5 8)) - -(define (dumpcode-nlocs x) - (bytes->integer x 8)) - -(define (dumpcode-nexts x) - (bytes->integer x 9)) - -(define (dumpcode-bytecode x) - (substring x 10)) - -(define (load-dumpcode file) - (let ((bytes (make-uniform-vector (stat:size (stat file)) #\a))) - (call-with-input-file file - (lambda (p) (uniform-vector-read! bytes p))) - bytes)) - -(define (save-dumpcode dump file) - (call-with-output-file file - (lambda (out) (uniform-vector-write dump out)))) - -(define (integer->bytes n) - (string (integer->char n))) - -(define (bytes->integer bytes start) - (char->integer (string-ref bytes start))) +(define (program-name x) + (hash-fold (lambda (s v d) (if (eq? x (variable-ref v)) s d)) x + (module-obarray (current-module)))) + ;;; ;;; Statistics interface ;;; -(export vms:time vms:clock) - -(define (vms:time stat) (vector-ref stat 0)) -(define (vms:clock stat) (vector-ref stat 1)) +(define-public (vms:time stat) (vector-ref stat 0)) +(define-public (vms:clock stat) (vector-ref stat 1)) diff --git a/module/system/vm/disasm.scm b/module/system/vm/disasm.scm index 0ab0a83d7..2e3c1ac87 100644 --- a/module/system/vm/disasm.scm +++ b/module/system/vm/disasm.scm @@ -27,15 +27,17 @@ :use-module (ice-9 format) :use-module (ice-9 receive) :use-module (ice-9 and-let-star) - :export (disassemble-dumpcode disassemble-program)) + :export (disassemble-objcode disassemble-program)) -(define (disassemble-dumpcode dumpcode . opts) - (if (not (dumpcode? dumpcode)) (error "Invalid dumpcode")) - (format #t "Disassembly of dumpcode:\n\n") - (format #t "Compiled for Guile VM ~A\n\n" (dumpcode-version dumpcode)) - (format #t "nlocs = ~A nexts = ~A\n\n" - (dumpcode-nlocs dumpcode) (dumpcode-nexts dumpcode)) - (disassemble-bytecode (dumpcode-bytecode dumpcode) #f)) +(define (disassemble-objcode objcode . opts) + (let* ((prog (objcode->program objcode)) + (arity (program-arity prog)) + (nlocs (caddr arity)) + (nexts (cadddr arity)) + (bytes (program-bytecode prog))) + (format #t "Disassembly of ~A:\n\n" objcode) + (format #t "nlocs = ~A nexts = ~A\n\n" nlocs nexts) + (disassemble-bytecode bytes #f))) (define (disassemble-program prog . opts) (let* ((arity (program-arity prog)) diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm deleted file mode 100644 index be696bc37..000000000 --- a/module/system/vm/frame.scm +++ /dev/null @@ -1,36 +0,0 @@ -;;; Guile VM frame utilities - -;; 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 frame) - :use-module (system vm core) - :export (frame->call)) - -(define (frame->call frame) - (let* ((prog (frame-program frame)) - (nargs (car (program-arity prog)))) - (do ((i 0 (1+ i)) - (l (vector->list (frame-variables frame)) (cdr l)) - (r '() (cons (car l) r))) - ((= i nargs) (cons (program-name prog) (reverse! r)))))) - -(define (program-name x) - (hash-fold (lambda (s v d) (if (eq? x (variable-ref v)) s d)) x - (module-obarray (current-module)))) diff --git a/module/system/vm/load.scm b/module/system/vm/load.scm deleted file mode 100644 index d440854fb..000000000 --- a/module/system/vm/load.scm +++ /dev/null @@ -1,60 +0,0 @@ -;;; Guile VM compiling loader - -;; 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 load) - :autoload (system base compile) (compile-file) - :use-module (system vm core) - :use-module (ice-9 regex) - :export (load-compiled-file compile-and-load load/compile)) - -(define (load-compiled-file file . opts) - (vm-load (the-vm) (load-dumpcode file))) - -(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-dumpcode compiled) opts) - (vm-load (the-vm) (load-dumpcode 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))) - -(define-public (object-file-name file) - (let ((m (string-match "\\.[^.]*$" file))) - (string-append (if m (match:prefix m) file) ".go"))) diff --git a/module/system/vm/profile.scm b/module/system/vm/profile.scm index 114b7524c..1b29850f1 100644 --- a/module/system/vm/profile.scm +++ b/module/system/vm/profile.scm @@ -24,7 +24,7 @@ :use-module (ice-9 format) :export (vm-profile)) -(define (vm-profile vm bytes . opts) +(define (vm-profile vm objcode . opts) (let ((flag (vm-option vm 'debug))) (dynamic-wind (lambda () @@ -34,7 +34,7 @@ (add-hook! (vm-enter-hook vm) profile-enter) (add-hook! (vm-exit-hook vm) profile-exit)) (lambda () - (let ((val (vm-load vm bytes))) + (let ((val (vm (objcode->program objcode)))) (display-result vm) val)) (lambda () diff --git a/module/system/vm/trace.scm b/module/system/vm/trace.scm index d7b074cdc..364069156 100644 --- a/module/system/vm/trace.scm +++ b/module/system/vm/trace.scm @@ -22,15 +22,13 @@ (define-module (system vm trace) :use-syntax (system base syntax) :use-module (system vm core) - :use-module (system vm frame) :use-module (ice-9 format) - :use-module (ice-9 and-let-star) :export (vm-trace vm-trace-on vm-trace-off)) -(define (vm-trace vm bytes . opts) +(define (vm-trace vm objcode . opts) (dynamic-wind (lambda () (apply vm-trace-on vm opts)) - (lambda () (vm-load vm bytes)) + (lambda () (vm (objcode->program objcode))) (lambda () (apply vm-trace-off vm opts)))) (define (vm-trace-on vm . opts) diff --git a/src/Makefile.am b/src/Makefile.am index b62036f9b..dcdd6eee3 100644 --- a/src/Makefile.am +++ b/src/Makefile.am @@ -5,12 +5,14 @@ guile_vm_LDADD = libguilevm.la guile_vm_LDFLAGS = $(GUILE_LDFLAGS) lib_LTLIBRARIES = libguilevm.la -libguilevm_la_SOURCES = envs.c instructions.c programs.c vm.c \ - envs.h instructions.h programs.h vm.h vm_engine.h vm_expand.h +libguilevm_la_SOURCES = \ + envs.c instructions.c objcodes.c programs.c vm.c \ + envs.h instructions.h objcodes.h programs.h vm.h \ + vm_engine.h vm_expand.h libguilevm_la_LDFLAGS = -version-info 0:0:0 -export-dynamic EXTRA_DIST = vm_engine.c vm_system.c vm_scheme.c vm_loader.c BUILT_SOURCES = vm_system.i vm_scheme.i vm_loader.i \ - envs.x instructions.x programs.x vm.x + envs.x instructions.x objcodes.x programs.x vm.x INCLUDES = $(GUILE_CFLAGS) DISTCLEANFILES = $(BUILT_SOURCES) @@ -27,4 +29,9 @@ SUFFIXES = .i .x $(SNARF) $< $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $< > $@ \ || { rm $@; false; } +GUILE = "$(bindir)/guile" +guilec: guilec.in + sed "s!@guile@!$(GUILE)!" guilec.in > guilec + @chmod 755 guilec + $(BUILT_SOURCES): config.h vm_expand.h diff --git a/src/envs.h b/src/envs.h index ddc5ea498..88884c1a3 100644 --- a/src/envs.h +++ b/src/envs.h @@ -39,8 +39,8 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -#ifndef _ENVS_H_ -#define _ENVS_H_ +#ifndef _SCM_ENVS_H_ +#define _SCM_ENVS_H_ #include #include "config.h" @@ -64,7 +64,7 @@ extern SCM scm_c_env_vcell (SCM env, SCM name, int intern); extern void scm_init_envs (void); -#endif /* _ENVS_H_ */ +#endif /* _SCM_ENVS_H_ */ /* Local Variables: diff --git a/src/guile-vm.c b/src/guile-vm.c index 581c30a88..1096b8abd 100644 --- a/src/guile-vm.c +++ b/src/guile-vm.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2000 Free Software Foundation, Inc. +/* 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 diff --git a/src/guilec.in b/src/guilec.in index 74f793753..529886c87 100755 --- a/src/guilec.in +++ b/src/guilec.in @@ -1,4 +1,4 @@ -#!@bindir@/guile -*- scheme -*- +#!@guile@ -s !# (use-modules (system base compile)) diff --git a/src/instructions.c b/src/instructions.c index 9c22e21be..6cfdf636f 100644 --- a/src/instructions.c +++ b/src/instructions.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2000 Free Software Foundation, Inc. +/* 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 diff --git a/src/instructions.h b/src/instructions.h index 2e62b9ed5..6b6757489 100644 --- a/src/instructions.h +++ b/src/instructions.h @@ -1,4 +1,4 @@ -/* Copyright (C) 2000 Free Software Foundation, Inc. +/* 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 @@ -39,8 +39,8 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -#ifndef _INSTRUCTIONS_H_ -#define _INSTRUCTIONS_H_ +#ifndef _SCM_INSTRUCTIONS_H_ +#define _SCM_INSTRUCTIONS_H_ #include #include "config.h" @@ -78,7 +78,7 @@ extern struct scm_instruction *scm_lookup_instruction (SCM name); extern void scm_init_instructions (void); -#endif /* _INSTRUCTIONS_H_ */ +#endif /* _SCM_INSTRUCTIONS_H_ */ /* Local Variables: diff --git a/src/objcodes.c b/src/objcodes.c new file mode 100644 index 000000000..0df3be0f3 --- /dev/null +++ b/src/objcodes.c @@ -0,0 +1,225 @@ +/* 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 software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + +#include +#include +#include +#include +#include +#include + +#include "programs.h" +#include "objcodes.h" + +#define OBJCODE_COOKIE "GOOF-0.5" + + +/* + * Objcode type + */ + +scm_bits_t scm_tc16_objcode; + +static SCM +make_objcode (size_t size) +#define FUNC_NAME "make_objcode" +{ + struct scm_objcode *p = SCM_MUST_MALLOC (sizeof (struct scm_objcode)); + p->size = size; + p->base = SCM_MUST_MALLOC (size); + p->fd = -1; + SCM_RETURN_NEWSMOB (scm_tc16_objcode, p); +} +#undef FUNC_NAME + +static SCM +make_objcode_by_mmap (int fd) +#define FUNC_NAME "make_objcode_by_mmap" +{ + int ret; + char *addr; + struct stat st; + struct scm_objcode *p; + + ret = fstat (fd, &st); + if (ret < 0) SCM_SYSERROR; + + addr = mmap (0, st.st_size, PROT_READ, MAP_SHARED, fd, 0); + if (addr == MAP_FAILED) SCM_SYSERROR; + + p = SCM_MUST_MALLOC (sizeof (struct scm_objcode)); + p->size = st.st_size; + p->base = addr; + p->fd = fd; + SCM_RETURN_NEWSMOB (scm_tc16_objcode, p); +} +#undef FUNC_NAME + +static scm_sizet +objcode_free (SCM obj) +#define FUNC_NAME "objcode_free" +{ + size_t size = (sizeof (struct scm_objcode)); + struct scm_objcode *p = SCM_OBJCODE_DATA (obj); + + if (p->fd >= 0) + { + int rv; + rv = munmap (p->base, p->size); + if (rv < 0) SCM_SYSERROR; + rv = close (p->fd); + if (rv < 0) SCM_SYSERROR; + } + else + { + size += p->size; + scm_must_free (p->base); + } + + scm_must_free (p); + return size; +} +#undef FUNC_NAME + + +/* + * Scheme interface + */ + +SCM_DEFINE (scm_objcode_p, "objcode?", 1, 0, 0, + (SCM obj), + "") +#define FUNC_NAME s_scm_objcode_p +{ + return SCM_BOOL (SCM_OBJCODE_P (obj)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 3, 0, 0, + (SCM bytecode, SCM nlocs, SCM nexts), + "") +#define FUNC_NAME s_scm_bytecode_to_objcode +{ + size_t size; + char *base; + SCM objcode; + + SCM_VALIDATE_STRING (1, bytecode); + SCM_VALIDATE_INUM (2, nlocs); + SCM_VALIDATE_INUM (3, nexts); + + size = SCM_STRING_LENGTH (bytecode) + 10; + objcode = make_objcode (size); + base = SCM_OBJCODE_BASE (objcode); + + memcpy (base, OBJCODE_COOKIE, 8); + base[8] = SCM_INUM (nlocs); + base[9] = SCM_INUM (nexts); + memcpy (base + 10, SCM_STRING_CHARS (bytecode), size - 10); + return objcode; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_load_objcode, "load-objcode", 1, 0, 0, + (SCM file), + "") +#define FUNC_NAME s_scm_load_objcode +{ + int fd; + + SCM_VALIDATE_STRING (1, file); + + fd = open (SCM_STRING_CHARS (file), O_RDONLY); + if (fd < 0) SCM_SYSERROR; + + return make_objcode_by_mmap (fd); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_objcode_to_string, "objcode->string", 1, 0, 0, + (SCM objcode), + "") +#define FUNC_NAME s_scm_objcode_to_string +{ + SCM_VALIDATE_OBJCODE (1, objcode); + return scm_makfromstr (SCM_OBJCODE_BASE (objcode), + SCM_OBJCODE_SIZE (objcode), + 0); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_objcode_to_program, "objcode->program", 1, 0, 0, + (SCM objcode), + "") +#define FUNC_NAME s_scm_objcode_to_program +{ + SCM prog; + size_t size; + char *base; + + SCM_VALIDATE_OBJCODE (1, objcode); + + base = SCM_OBJCODE_BASE (objcode); + size = SCM_OBJCODE_SIZE (objcode); + prog = scm_c_make_program (base + 10, size - 10, objcode); + SCM_PROGRAM_NLOCS (prog) = base[8]; + SCM_PROGRAM_NEXTS (prog) = base[9]; + return prog; +} +#undef FUNC_NAME + + +void +scm_init_objcodes (void) +{ + scm_tc16_objcode = scm_make_smob_type ("objcode", 0); + scm_set_smob_free (scm_tc16_objcode, objcode_free); + +#ifndef SCM_MAGIC_SNARFER +#include "objcodes.x" +#endif +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/src/objcodes.h b/src/objcodes.h new file mode 100644 index 000000000..20afd042a --- /dev/null +++ b/src/objcodes.h @@ -0,0 +1,72 @@ +/* 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 software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + +#ifndef _SCM_OBJCODES_H_ +#define _SCM_OBJCODES_H_ + +#include +#include "config.h" + +struct scm_objcode { + size_t size; /* objcode size */ + char *base; /* objcode base address */ + int fd; /* file descriptor when mmap'ed */ +}; + +extern scm_bits_t scm_tc16_objcode; + +#define SCM_OBJCODE_P(x) (SCM_SMOB_PREDICATE (scm_tc16_objcode, x)) +#define SCM_OBJCODE_DATA(x) ((struct scm_objcode *) SCM_SMOB_DATA (x)) +#define SCM_VALIDATE_OBJCODE(p,x) SCM_MAKE_VALIDATE (p, x, OBJCODE_P) + +#define SCM_OBJCODE_SIZE(x) (SCM_OBJCODE_DATA (x)->size) +#define SCM_OBJCODE_BASE(x) (SCM_OBJCODE_DATA (x)->base) +#define SCM_OBJCODE_FD(x) (SCM_OBJCODE_DATA (x)->fd) + +extern void scm_init_objcodes (void); + +#endif /* _SCM_OBJCODES_H_ */ + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/src/programs.c b/src/programs.c index 406c00952..d6d7ab8e2 100644 --- a/src/programs.c +++ b/src/programs.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2000 Free Software Foundation, Inc. +/* 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 diff --git a/src/programs.h b/src/programs.h index b8fa563fc..f5fa3be03 100644 --- a/src/programs.h +++ b/src/programs.h @@ -1,4 +1,4 @@ -/* Copyright (C) 2000 Free Software Foundation, Inc. +/* 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 @@ -39,8 +39,8 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -#ifndef _PROGRAM_H_ -#define _PROGRAM_H_ +#ifndef _SCM_PROGRAMS_H_ +#define _SCM_PROGRAMS_H_ #include #include "config.h" @@ -87,7 +87,7 @@ extern SCM scm_c_make_closure (SCM program, SCM external); extern void scm_init_programs (void); -#endif /* _PROGRAM_H_ */ +#endif /* _SCM_PROGRAMS_H_ */ /* Local Variables: diff --git a/src/vm.c b/src/vm.c index ff2ea09df..d09602075 100644 --- a/src/vm.c +++ b/src/vm.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2000 Free Software Foundation, Inc. +/* 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 @@ -42,6 +42,7 @@ #include #include "instructions.h" #include "programs.h" +#include "objcodes.h" #include "envs.h" #include "vm.h" @@ -598,35 +599,6 @@ SCM_DEFINE (scm_vm_fetch_stack, "vm-fetch-stack", 1, 0, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_vm_load, "vm-load", 2, 0, 0, - (SCM vm, SCM bootcode), - "") -#define FUNC_NAME s_scm_vm_load -{ - SCM prog; - int len; - char *base; - - SCM_VALIDATE_VM (1, vm); - SCM_VALIDATE_STRING (2, bootcode); - - base = SCM_STRING_CHARS (bootcode); - len = SCM_STRING_LENGTH (bootcode); - - /* Check bootcode */ - if (strncmp (base, "\0GBC", 4) != 0) - SCM_MISC_ERROR ("Invalid bootcode: ~S", SCM_LIST1 (bootcode)); - - /* Create program */ - prog = scm_c_make_program (base + 10, len - 10, bootcode); - SCM_PROGRAM_NLOCS (prog) = base[8]; - SCM_PROGRAM_NEXTS (prog) = base[9]; - - /* Load it */ - return scm_vm_apply (vm, prog, SCM_EOL); -} -#undef FUNC_NAME - /* * Initialize @@ -637,6 +609,7 @@ scm_init_vm (void) { scm_init_instructions (); scm_init_programs (); + scm_init_objcodes (); scm_tc16_vm_heap_frame = scm_make_smob_type ("vm_frame", 0); scm_set_smob_mark (scm_tc16_vm_heap_frame, vm_heap_frame_mark); diff --git a/src/vm.h b/src/vm.h index ffc289db3..5faac62fe 100644 --- a/src/vm.h +++ b/src/vm.h @@ -1,4 +1,4 @@ -/* Copyright (C) 2000 Free Software Foundation, Inc. +/* 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 @@ -39,8 +39,8 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -#ifndef _VM_H_ -#define _VM_H_ +#ifndef _SCM_VM_H_ +#define _SCM_VM_H_ #include #include "config.h" @@ -151,7 +151,7 @@ extern SCM scm_vm_current_frame (SCM vm); extern void scm_init_vm (void); -#endif /* _VM_H_ */ +#endif /* _SCM_VM_H_ */ /* Local Variables: diff --git a/src/vm_engine.c b/src/vm_engine.c index 1d6b53037..dc02f8fdf 100644 --- a/src/vm_engine.c +++ b/src/vm_engine.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2000 Free Software Foundation, Inc. +/* 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 diff --git a/src/vm_engine.h b/src/vm_engine.h index 16f1b8585..37320d901 100644 --- a/src/vm_engine.h +++ b/src/vm_engine.h @@ -1,4 +1,4 @@ -/* Copyright (C) 2000 Free Software Foundation, Inc. +/* 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 diff --git a/src/vm_expand.h b/src/vm_expand.h index 911b1bd49..8124c0539 100644 --- a/src/vm_expand.h +++ b/src/vm_expand.h @@ -1,4 +1,4 @@ -/* Copyright (C) 2000 Free Software Foundation, Inc. +/* 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 diff --git a/src/vm_loader.c b/src/vm_loader.c index 02af7859e..5469fcef8 100644 --- a/src/vm_loader.c +++ b/src/vm_loader.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2000 Free Software Foundation, Inc. +/* 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 diff --git a/src/vm_scheme.c b/src/vm_scheme.c index ac1c09c8c..bb552d948 100644 --- a/src/vm_scheme.c +++ b/src/vm_scheme.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2000 Free Software Foundation, Inc. +/* 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 diff --git a/src/vm_system.c b/src/vm_system.c index 3ac1d6726..c0f14e444 100644 --- a/src/vm_system.c +++ b/src/vm_system.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2000 Free Software Foundation, Inc. +/* 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