summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorKeisuke Nishida <kxn30@po.cwru.edu>2001-04-05 01:38:38 +0000
committerKeisuke Nishida <kxn30@po.cwru.edu>2001-04-05 01:38:38 +0000
commitea9b4b29f39cdc3e17222f0c35462d29c80a6089 (patch)
tree091e38e3fea3c139f92c554c9b37799590700348
parent4ee5686f6cc16cc78df4eecb10eab25268e74835 (diff)
downloadguile-ea9b4b29f39cdc3e17222f0c35462d29c80a6089.tar.gz
*** empty log message ***
-rw-r--r--module/language/elisp/spec.scm33
-rw-r--r--module/language/elisp/translate.scm45
-rw-r--r--module/language/gscheme/spec.scm90
-rw-r--r--module/language/r5rs/translate.scm8
-rw-r--r--module/system/il/compile.scm2
-rw-r--r--module/system/repl/command.gsm488
-rw-r--r--module/system/repl/command.scm473
-rw-r--r--module/system/vm/assemble.scm4
-rw-r--r--module/system/vm/conv.scm6
-rw-r--r--module/system/vm/load.scm2
-rw-r--r--src/vm_engine.h2
-rw-r--r--src/vm_loader.c14
-rw-r--r--src/vm_system.c46
13 files changed, 684 insertions, 529 deletions
diff --git a/module/language/elisp/spec.scm b/module/language/elisp/spec.scm
new file mode 100644
index 000000000..4f185522e
--- /dev/null
+++ b/module/language/elisp/spec.scm
@@ -0,0 +1,33 @@
+;;; Guile Emac Lisp language specification
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This file is part of Guile VM.
+
+;; Guile VM 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.
+;;
+;; Guile VM 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 Guile VM; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+(define-module (lang elisp spec)
+ :use-module (system lang language)
+ :use-module (lang elisp translate)
+ :export (elisp))
+
+(define-language elisp
+ #:title "Emacs Lisp"
+ #:version "0.0"
+ #:reader read
+ #:expander id
+ #:translator translate
+ )
diff --git a/module/language/elisp/translate.scm b/module/language/elisp/translate.scm
new file mode 100644
index 000000000..32b6e6dd6
--- /dev/null
+++ b/module/language/elisp/translate.scm
@@ -0,0 +1,45 @@
+;;; Emacs Lisp to GHIL translator
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This file is part of Guile VM.
+
+;; Guile VM 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.
+;;
+;; Guile VM 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 Guile VM; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+(define-module (lang elisp translate)
+ :export (translate))
+
+(define (translate x) (trans x))
+
+(define (trans x)
+ (if (pair? x)
+ (trans-pair x)
+ x))
+
+(define (trans-pair x)
+ (let ((name (car x)) (args (cdr x)))
+ (case name
+ ((quote) `(@quote ,@args))
+ ((defvar) `(@define ,@(map trans args)))
+ ((setq) `(@set! ,@(map trans args)))
+ ((if) `(@if ,(trans (car args)) (@begin ,@(map trans (cdr args)))))
+ ((and) `(@and ,@(map trans args)))
+ ((or) `(@or ,@(map trans args)))
+ ((progn) `(@begin ,@(map trans args)))
+ ((defun) `(@define ,(car args)
+ (@lambda ,(cadr args) ,@(map trans (cddr args)))))
+ ((lambda) `(@lambda ,(car args) ,@(map trans (cdr args))))
+ (else x))))
diff --git a/module/language/gscheme/spec.scm b/module/language/gscheme/spec.scm
new file mode 100644
index 000000000..c2a9ed7b6
--- /dev/null
+++ b/module/language/gscheme/spec.scm
@@ -0,0 +1,90 @@
+;;; Guile Scheme specification
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; Guile VM 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.
+;;
+;; Guile VM 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 Guile VM; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+(define-module (language gscheme spec)
+ :use-module (system base language)
+ :use-module (ice-9 match)
+ :export (gscheme))
+
+
+;;;
+;;; Macro expander
+;;;
+
+(define (expand x)
+ (if (pair? x)
+ (let* ((s (car x))
+ (m (current-module))
+ (v (and (symbol? s) (module-defined? m s) (module-ref m s))))
+ (if (defmacro? v)
+ (expand (apply (defmacro-transformer v) (cdr x)))
+ (cons (expand (car x)) (expand (cdr x)))))
+ x))
+
+
+;;;
+;;; Translator
+;;;
+
+(define *primitive-procedure-list*
+ '(void car cdr cons + - < >))
+
+(define (translate x) (if (pair? x) (translate-pair x) x))
+
+(define (translate-pair x)
+ (let ((name (car x)) (args (cdr x)))
+ (case name
+ ((quote) (cons '@quote args))
+ ((set! if and or begin)
+ (cons (symbol-append '@ name) (map translate args)))
+ ((define)
+ (if (pair? (car args))
+ `(@define ,(caar args)
+ (@lambda ,(cdar args) ,@(map translate (cdr args))))
+ `(@define ,(car args) ,@(map translate (cdr args)))))
+ ((let let* letrec)
+ (match x
+ (('let (? symbol? f) ((s v) ...) body ...)
+ `(@letrec ((,f (@lambda ,s ,@(map translate body))))
+ (,f ,@(map translate v))))
+ (else
+ (cons* (symbol-append '@ name)
+ (map (lambda (b) (cons (car b) (map translate (cdr b))))
+ (car args))
+ (map translate (cdr args))))))
+ ((lambda)
+ (cons* '@lambda (car args) (map translate (cdr args))))
+ (else
+ (if (memq name *primitive-procedure-list*)
+ (cons (symbol-append '@ name) (map translate args))
+ (cons (translate name) (map translate args)))))))
+
+
+;;;
+;;; Language definition
+;;;
+
+(define-language gscheme
+ :title "Guile Scheme"
+ :version "0.3"
+ :reader read
+ :expander expand
+ :translator translate
+ :printer write
+ )
diff --git a/module/language/r5rs/translate.scm b/module/language/r5rs/translate.scm
index 5bf18758b..74d008c02 100644
--- a/module/language/r5rs/translate.scm
+++ b/module/language/r5rs/translate.scm
@@ -26,9 +26,6 @@
(define (trans x) (if (pair? x) (trans-pair x) x))
-(define *primitive-procedure-list*
- '(void car cdr cons + - * / < >))
-
(define (trans-pair x)
(let ((name (car x)) (args (cdr x)))
(let ((il (case name
@@ -45,10 +42,7 @@
(cons* '@lambda (trans-formals (car args))
(map trans (cdr args))))
(else
- (if (memq name *primitive-procedure-list*)
- ;; FIXME: Temporary hack for direct optimization
- (cons (symbol-append '@ name) (map trans args))
- (cons (trans name) (map trans args))))))
+ (cons (trans name) (map trans args)))))
(props (source-properties x)))
(if (not (null? props))
(set-source-properties! il props))
diff --git a/module/system/il/compile.scm b/module/system/il/compile.scm
index 3384e25f4..68b3f42d5 100644
--- a/module/system/il/compile.scm
+++ b/module/system/il/compile.scm
@@ -120,7 +120,7 @@
(comp-push test)
(push-code! (make-<glil-branch> 'br-if-not L1))
(comp-tail then)
- (if (not tail) (push-code! (make-<glil-jump> L2)))
+ (if (not tail) (push-code! (make-<glil-branch> 'jump L2)))
(push-code! (make-<glil-label> L1))
(comp-tail else)
(if (not tail) (push-code! (make-<glil-label> L2)))))
diff --git a/module/system/repl/command.gsm b/module/system/repl/command.gsm
new file mode 100644
index 000000000..97b2e62c6
--- /dev/null
+++ b/module/system/repl/command.gsm
@@ -0,0 +1,488 @@
+;;; REPL commands
+
+;; 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 (puts x) (display x) (newline))
+
+(define (user-error msg . args)
+ (throw 'user-error #f msg args #f))
+
+
+;;;
+;;; Meta command
+;;;
+
+(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))
+ (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))))
+
+(define (group-name g) (car g))
+(define (group-commands g) (cdr g))
+
+(define *command-module* (current-module))
+(define (command-name c) (car c))
+(define (command-abbrev c) (if (null? (cdr c)) #f (cadr c)))
+(define (command-procedure c) (module-ref *command-module* (command-name c)))
+(define (command-doc c) (procedure-documentation (command-procedure c)))
+
+(define (command-usage c)
+ (let ((doc (command-doc c)))
+ (substring doc 0 (string-index doc #\newline))))
+
+(define (command-summary c)
+ (let* ((doc (command-doc c))
+ (start (1+ (string-index doc #\newline))))
+ (cond ((string-index doc #\newline start)
+ => (lambda (end) (substring doc start end)))
+ (else (substring doc start)))))
+
+(define (lookup-group name)
+ (assq name *command-table*))
+
+(define (lookup-command key)
+ (let loop ((groups *command-table*) (commands '()))
+ (cond ((and (null? groups) (null? commands)) #f)
+ ((null? commands)
+ (loop (cdr groups) (cdar groups)))
+ ((memq key (car commands)) (car commands))
+ (else (loop groups (cdr commands))))))
+
+(define (display-group group . opts)
+ (format #t "~:(~A~) Commands [abbrev]:~2%" (group-name group))
+ (for-each (lambda (c)
+ (display-summary (command-usage c)
+ (command-abbrev c)
+ (command-summary c)))
+ (group-commands group))
+ (newline))
+
+(define (display-command command)
+ (display "Usage: ")
+ (display (command-doc command))
+ (newline))
+
+(define (display-summary usage abbrev summary)
+ (let ((abbrev (if abbrev (format #f "[,~A]" abbrev) "")))
+ (format #t " ,~24A ~8@A - ~A\n" usage abbrev summary)))
+
+(define (meta-command repl line)
+ (let ((input (call-with-input-string (string-append "(" line ")") read)))
+ (if (not (null? input))
+ (do ((key (car input))
+ (args (cdr input) (cdr args))
+ (opts '() (cons (make-keyword-from-dash-symbol (car args)) opts)))
+ ((or (null? args)
+ (not (symbol? (car args)))
+ (not (eq? (string-ref (symbol->string (car args)) 0) #\-)))
+ (let ((c (lookup-command key)))
+ (if c
+ (cond ((memq :h opts) (display-command c))
+ (else (apply (command-procedure c)
+ repl (append! args opts))))
+ (user-error "Unknown meta command: ~A" key))))))))
+
+
+;;;
+;;; Help commands
+;;;
+
+(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 :)"
+ (match args
+ (()
+ (display-group (lookup-group 'help))
+ (display "Command Groups:\n\n")
+ (display-summary "help all" #f "List all commands")
+ (for-each (lambda (g)
+ (let* ((name (symbol->string (group-name g)))
+ (usage (string-append "help " name))
+ (header (string-append "List " name " commands")))
+ (display-summary usage #f header)))
+ (cdr *command-table*))
+ (newline)
+ (display "Enter `,COMMAND -h' to display 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)))))
+
+(define guile-apropos apropos)
+(define (apropos repl regexp)
+ "apropos [options] REGEXP
+Find bindings/modules/packages."
+ (guile-apropos (object->string regexp display)))
+
+(define (describe repl obj)
+ "describe OBJ
+Show description/documentation."
+ (display "Not implemented yet\n"))
+
+(define (option repl . args)
+ "option [KEY [VALUE]]
+List/show/set options."
+ (display "Not implemented yet\n"))
+
+(define (quit repl)
+ "quit
+Quit this session."
+ (throw 'quit))
+
+
+;;;
+;;; Module commands
+;;;
+
+(define (module repl . args)
+ "module [MODULE]
+Change modules / Show current module."
+ (match args
+ (() (puts (binding repl.module)))))
+
+(define (use repl . args)
+ "use [MODULE ...]
+Use modules."
+ (define (use name)
+ (let ((mod (resolve-interface name)))
+ (if mod
+ (module-use! repl.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))))
+ (for-each (lambda (name)
+ (cond
+ ((pair? name) (use name))
+ ((symbol? name)
+ (cond ((find-one-module (symbol->string name)) => use)))
+ (else (user-error "Invalid module name: ~A" name))))
+ args)))
+
+(define (import repl . args)
+ "import [MODULE ...]
+Import modules / List those imported."
+ (define (use name)
+ (let ((mod (resolve-interface name)))
+ (if mod
+ (module-use! repl.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))))
+ (for-each (lambda (name)
+ (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))))
+ args)))
+
+(define (load repl file . opts)
+ "load [options] FILE
+Load a file in the current module."
+ (apply repl-load-file repl (->string file) opts))
+
+(define (binding repl . opts)
+ "binding [-a]
+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))
+
+
+;;;
+;;; Language commands
+;;;
+
+(define (language repl name)
+ "language LANGUAGE
+Change languages."
+ (set! repl.language (lookup-language name))
+ (repl-welcome repl))
+
+
+;;;
+;;; Compile commands
+;;;
+
+(define (compile repl form . opts)
+ "compile [options] FORM
+Generate compiled code.
+
+ -e Stop after expanding syntax/macro
+ -t Stop after translating into GHIL
+ -c Stop after generating GLIL
+ -l Stop before linking
+ -o Compile into bytecode
+
+ -O Enable optimization
+ -D Add debug information"
+ (let ((x (apply repl-compile repl form opts)))
+ (cond ((null? opts)
+ (disassemble-program x))
+ ((memq :l opts)
+ (disassemble-bytecode x))
+ ((memq :c opts)
+ (pprint-glil x))
+ (else
+ (puts x)))))
+
+(define (compile-file repl file . opts)
+ "compile-file [options] FILE
+Compile a file."
+ (apply repl-compile-file repl (->string file) opts))
+
+(define (disassemble repl prog)
+ "disassemble PROGRAM
+Disassemble a program."
+ (disassemble-program (repl.vm (repl-compile repl prog))))
+
+(define (disassemble-file repl file)
+ "disassemble-file FILE
+Disassemble a file."
+ (disassemble-bytecode (load-file-in (->string file)
+ repl.module
+ repl.language)))
+
+(define (->string x)
+ (object->string x display))
+
+
+;;;
+;;; Profile commands
+;;;
+
+(define (profile repl form . opts)
+ "profile FORM
+Profile execution."
+ (apply vm-profile repl.vm (repl-compile repl form) opts))
+
+
+;;;
+;;; Debug commands
+;;;
+
+(define guile-backtrace backtrace)
+(define (backtrace repl)
+ "backtrace
+Show backtrace (if any)."
+ (guile-backtrace))
+
+(define (debugger repl)
+ "debugger
+Start debugger."
+ (debug))
+
+(define (trace repl form . opts)
+ "trace [-a] FORM
+Trace execution."
+ (apply vm-trace repl.vm (repl-compile repl form) opts))
+
+(define (step repl)
+ "step FORM
+Step execution."
+ (display "Not implemented yet\n"))
+
+
+;;;
+;;; 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))
+
+;;;
+;;; Statistics
+;;;
+
+(define guile-gc gc)
+(define (gc repl)
+ "gc
+Garbage collection."
+ (guile-gc))
+
+(define (display-stat title flag field1 field2 unit)
+ (let ((str (format #f "~~20~AA ~~10@A /~~10@A ~~A~~%" (if flag "" "@"))))
+ (format #t str title field1 field2 unit)))
+
+(define (display-stat-title title field1 field2)
+ (display-stat title #t field1 field2 ""))
+
+(define (display-diff-stat title flag this last unit)
+ (display-stat title flag (- this last) this unit))
+
+(define (display-time-stat title this last)
+ (define (conv num)
+ (format #f "~10,2F" (/ num internal-time-units-per-second)))
+ (display-stat title #f (conv (- this last)) (conv this) "s"))
+
+(define (display-mips-stat title this-time this-clock last-time last-clock)
+ (define (mips time clock)
+ (if (= time 0) "----" (format #f "~10,2F" (/ clock time 1000000))))
+ (display-stat title #f
+ (mips (- this-time last-time) (- this-clock last-clock))
+ (mips this-time this-clock) "mips"))
+
+(define (statistics repl)
+ "statistics
+Display statistics."
+ (let ((this-tms (times))
+ (this-vms (vm-stats repl.vm))
+ (this-gcs (gc-stats))
+ (last-tms repl.tm-stats)
+ (last-vms repl.vm-stats)
+ (last-gcs repl.gc-stats))
+ ;; GC times
+ (let ((this-times (assq-ref this-gcs 'gc-times))
+ (last-times (assq-ref last-gcs 'gc-times)))
+ (display-diff-stat "GC times:" #t this-times last-times "times")
+ (newline))
+ ;; Memory size
+ (let ((this-cells (assq-ref this-gcs 'cells-allocated))
+ (this-heap (assq-ref this-gcs 'cell-heap-size))
+ (this-bytes (assq-ref this-gcs 'bytes-malloced))
+ (this-malloc (assq-ref this-gcs 'gc-malloc-threshold)))
+ (display-stat-title "Memory size:" "current" "limit")
+ (display-stat "heap" #f this-cells this-heap "cells")
+ (display-stat "malloc" #f this-bytes this-malloc "bytes")
+ (newline))
+ ;; Cells collected
+ (let ((this-marked (assq-ref this-gcs 'cells-marked))
+ (last-marked (assq-ref last-gcs 'cells-marked))
+ (this-swept (assq-ref this-gcs 'cells-swept))
+ (last-swept (assq-ref last-gcs 'cells-swept)))
+ (display-stat-title "Cells collected:" "diff" "total")
+ (display-diff-stat "marked" #f this-marked last-marked "cells")
+ (display-diff-stat "swept" #f this-swept last-swept "cells")
+ (newline))
+ ;; GC time taken
+ (let ((this-mark (assq-ref this-gcs 'gc-mark-time-taken))
+ (last-mark (assq-ref last-gcs 'gc-mark-time-taken))
+ (this-sweep (assq-ref this-gcs 'gc-sweep-time-taken))
+ (last-sweep (assq-ref last-gcs 'gc-sweep-time-taken))
+ (this-total (assq-ref this-gcs 'gc-time-taken))
+ (last-total (assq-ref last-gcs 'gc-time-taken)))
+ (display-stat-title "GC time taken:" "diff" "total")
+ (display-time-stat "mark" this-mark last-mark)
+ (display-time-stat "sweep" this-sweep last-sweep)
+ (display-time-stat "total" this-total last-total)
+ (newline))
+ ;; Process time spent
+ (let ((this-utime (tms:utime this-tms))
+ (last-utime (tms:utime last-tms))
+ (this-stime (tms:stime this-tms))
+ (last-stime (tms:stime last-tms))
+ (this-cutime (tms:cutime this-tms))
+ (last-cutime (tms:cutime last-tms))
+ (this-cstime (tms:cstime this-tms))
+ (last-cstime (tms:cstime last-tms)))
+ (display-stat-title "Process time spent:" "diff" "total")
+ (display-time-stat "user" this-utime last-utime)
+ (display-time-stat "system" this-stime last-stime)
+ (display-time-stat "child user" this-cutime last-cutime)
+ (display-time-stat "child system" this-cstime last-cstime)
+ (newline))
+ ;; VM statistics
+ (let ((this-time (vms:time this-vms))
+ (last-time (vms:time last-vms))
+ (this-clock (vms:clock this-vms))
+ (last-clock (vms:clock last-vms)))
+ (display-stat-title "VM statistics:" "diff" "total")
+ (display-time-stat "time spent" this-time last-time)
+ (display-diff-stat "bogoclock" #f this-clock last-clock "clock")
+ (display-mips-stat "bogomips" this-time this-clock last-time last-clock)
+ (newline))
+ ;; Save statistics
+ ;; Save statistics
+ (set! repl.tm-stats this-tms)
+ (set! repl.vm-stats this-vms)
+ (set! repl.gc-stats this-gcs)))
diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm
index 6a2c56682..25e723163 100644
--- a/module/system/repl/command.scm
+++ b/module/system/repl/command.scm
@@ -1,4 +1,4 @@
-;;; command.scm --- REPL commands
+;;; REPL commands
;; Copyright (C) 2001 Free Software Foundation, Inc.
@@ -26,6 +26,7 @@
:use-module (system repl common)
:use-module (system il glil)
:use-module (system vm core)
+ :use-module (system vm load)
:use-module (system vm trace)
:use-module (system vm disasm)
:use-module (system vm profile)
@@ -34,472 +35,4 @@
:use-module (ice-9 debugger)
:export (meta-command))
-(define (puts x) (display x) (newline))
-
-(define (user-error msg . args)
- (throw 'user-error #f msg args #f))
-
-
-;;;
-;;; Meta command
-;;;
-
-(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))
- (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))))
-
-(define (group-name g) (car g))
-(define (group-commands g) (cdr g))
-
-(define *command-module* (current-module))
-(define (command-name c) (car c))
-(define (command-abbrev c) (if (null? (cdr c)) #f (cadr c)))
-(define (command-procedure c) (module-ref *command-module* (command-name c)))
-(define (command-doc c) (procedure-documentation (command-procedure c)))
-
-(define (command-usage c)
- (let ((doc (command-doc c)))
- (substring doc 0 (string-index doc #\newline))))
-
-(define (command-summary c)
- (let* ((doc (command-doc c))
- (start (1+ (string-index doc #\newline))))
- (cond ((string-index doc #\newline start)
- => (lambda (end) (substring doc start end)))
- (else (substring doc start)))))
-
-(define (lookup-group name)
- (assq name *command-table*))
-
-(define (lookup-command key)
- (let loop ((groups *command-table*) (commands '()))
- (cond ((and (null? groups) (null? commands)) #f)
- ((null? commands)
- (loop (cdr groups) (cdar groups)))
- ((memq key (car commands)) (car commands))
- (else (loop groups (cdr commands))))))
-
-(define (display-group group . opts)
- (format #t "~:(~A~) Commands [abbrev]:~2%" (group-name group))
- (for-each (lambda (c)
- (display-summary (command-usage c)
- (command-abbrev c)
- (command-summary c)))
- (group-commands group))
- (newline))
-
-(define (display-command command)
- (display "Usage: ")
- (display (command-doc command))
- (newline))
-
-(define (display-summary usage abbrev summary)
- (let ((abbrev (if abbrev (format #f "[,~A]" abbrev) "")))
- (format #t " ,~24A ~8@A - ~A\n" usage abbrev summary)))
-
-(define (meta-command repl line)
- (let ((input (call-with-input-string (string-append "(" line ")") read)))
- (if (not (null? input))
- (do ((key (car input))
- (args (cdr input) (cdr args))
- (opts '() (cons (make-keyword-from-dash-symbol (car args)) opts)))
- ((or (null? args)
- (not (symbol? (car args)))
- (not (eq? (string-ref (symbol->string (car args)) 0) #\-)))
- (let ((c (lookup-command key)))
- (if c
- (cond ((memq :h opts) (display-command c))
- (else (apply (command-procedure c)
- repl (append! args opts))))
- (user-error "Unknown meta command: ~A" key))))))))
-
-
-;;;
-;;; Help commands
-;;;
-
-(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 :)"
- (match args
- (()
- (display-group (lookup-group 'help))
- (display "Command Groups:\n\n")
- (display-summary "help all" #f "List all commands")
- (for-each (lambda (g)
- (let* ((name (symbol->string (group-name g)))
- (usage (string-append "help " name))
- (header (string-append "List " name " commands")))
- (display-summary usage #f header)))
- (cdr *command-table*))
- (newline)
- (display "Enter `,COMMAND -h' to display 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)))))
-
-(define guile-apropos apropos)
-(define (apropos repl regexp)
- "apropos [options] REGEXP
-Find bindings/modules/packages."
- (guile-apropos (object->string regexp display)))
-
-(define (describe repl obj)
- "describe OBJ
-Show description/documentation."
- (display "Not implemented yet\n"))
-
-(define (option repl . args)
- "option [KEY [VALUE]]
-List/show/set options."
- (display "Not implemented yet\n"))
-
-(define (quit repl)
- "quit
-Quit this session."
- (throw 'quit))
-
-
-;;;
-;;; Module commands
-;;;
-
-(define (module repl . args)
- "module [MODULE]
-Change modules / Show current module."
- (match args
- (() (puts (binding repl.module)))))
-
-(define (use repl . args)
- "use [MODULE ...]
-Use modules."
- (define (use name)
- (let ((mod (resolve-interface name)))
- (if mod
- (module-use! repl.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))))
- (for-each (lambda (name)
- (cond
- ((pair? name) (use name))
- ((symbol? name)
- (cond ((find-one-module (symbol->string name)) => use)))
- (else (user-error "Invalid module name: ~A" name))))
- args)))
-
-(define (import repl . args)
- "import [MODULE ...]
-Import modules / List those imported."
- (define (use name)
- (let ((mod (resolve-interface name)))
- (if mod
- (module-use! repl.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))))
- (for-each (lambda (name)
- (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))))
- args)))
-
-(define (load repl file . opts)
- "load [options] FILE
-Load a file in the current module."
- (apply repl-load-file repl (->string file) opts))
-
-(define (binding repl . opts)
- "binding [-a]
-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))
-
-
-;;;
-;;; Language commands
-;;;
-
-(define (language repl name)
- "language LANGUAGE
-Change languages."
- (set! repl.language (lookup-language name))
- (repl-welcome repl))
-
-
-;;;
-;;; Compile commands
-;;;
-
-(define (compile repl form . opts)
- "compile [options] FORM
-Generate compiled code.
-
- -e Stop after expanding syntax/macro
- -t Stop after translating into GHIL
- -c Stop after generating GLIL
- -l Stop before linking
- -o Compile into bytecode
-
- -O Enable optimization
- -D Add debug information"
- (let ((x (apply repl-compile repl form opts)))
- (cond ((null? opts)
- (disassemble-program x))
- ((memq :l opts)
- (disassemble-bytecode x))
- ((memq :c opts)
- (pprint-glil x))
- (else
- (puts x)))))
-
-(define (compile-file repl file . opts)
- "compile-file [options] FILE
-Compile a file."
- (apply repl-compile-file repl (->string file) opts))
-
-(define (disassemble repl prog)
- "disassemble PROGRAM
-Disassemble a program."
- (disassemble-program (repl.vm (repl-compile repl prog))))
-
-(define (disassemble-file repl file)
- "disassemble-file FILE
-Disassemble a file."
- (disassemble-bytecode (load-file-in (->string file)
- repl.module
- repl.language)))
-
-(define (->string x)
- (object->string x display))
-
-
-;;;
-;;; Profile commands
-;;;
-
-(define (profile repl form . opts)
- "profile FORM
-Profile execution."
- (apply vm-profile repl.vm (repl-compile repl form) opts))
-
-
-;;;
-;;; Debug commands
-;;;
-
-(define guile-backtrace backtrace)
-(define (backtrace repl)
- "backtrace
-Show backtrace (if any)."
- (guile-backtrace))
-
-(define (debugger repl)
- "debugger
-Start debugger."
- (debug))
-
-(define (trace repl form . opts)
- "trace [-a] FORM
-Trace execution."
- (apply vm-trace repl.vm (repl-compile repl form) opts))
-
-(define (step repl)
- "step FORM
-Step execution."
- (display "Not implemented yet\n"))
-
-
-;;;
-;;; 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))
-
-;;;
-;;; Statistics
-;;;
-
-(define guile-gc gc)
-(define (gc repl)
- "gc
-Garbage collection."
- (guile-gc))
-
-(define (display-stat title flag field1 field2 unit)
- (let ((str (format #f "~~20~AA ~~10@A /~~10@A ~~A~~%" (if flag "" "@"))))
- (format #t str title field1 field2 unit)))
-
-(define (display-stat-title title field1 field2)
- (display-stat title #t field1 field2 ""))
-
-(define (display-diff-stat title flag this last unit)
- (display-stat title flag (- this last) this unit))
-
-(define (display-time-stat title this last)
- (define (conv num)
- (format #f "~10,2F" (/ num internal-time-units-per-second)))
- (display-stat title #f (conv (- this last)) (conv this) "s"))
-
-(define (display-mips-stat title this-time this-clock last-time last-clock)
- (define (mips time clock)
- (if (= time 0) "----" (format #f "~10,2F" (/ clock time 1000000))))
- (display-stat title #f
- (mips (- this-time last-time) (- this-clock last-clock))
- (mips this-time this-clock) "mips"))
-
-(define (statistics repl)
- "statistics
-Display statistics."
- (let ((this-tms (times))
- (this-vms (vm-stats repl.vm))
- (this-gcs (gc-stats))
- (last-tms repl.tm-stats)
- (last-vms repl.vm-stats)
- (last-gcs repl.gc-stats))
- ;; GC times
- (let ((this-times (assq-ref this-gcs 'gc-times))
- (last-times (assq-ref last-gcs 'gc-times)))
- (display-diff-stat "GC times:" #t this-times last-times "times")
- (newline))
- ;; Memory size
- (let ((this-cells (assq-ref this-gcs 'cells-allocated))
- (this-heap (assq-ref this-gcs 'cell-heap-size))
- (this-bytes (assq-ref this-gcs 'bytes-malloced))
- (this-malloc (assq-ref this-gcs 'gc-malloc-threshold)))
- (display-stat-title "Memory size:" "current" "limit")
- (display-stat "heap" #f this-cells this-heap "cells")
- (display-stat "malloc" #f this-bytes this-malloc "bytes")
- (newline))
- ;; Cells collected
- (let ((this-marked (assq-ref this-gcs 'cells-marked))
- (last-marked (assq-ref last-gcs 'cells-marked))
- (this-swept (assq-ref this-gcs 'cells-swept))
- (last-swept (assq-ref last-gcs 'cells-swept)))
- (display-stat-title "Cells collected:" "diff" "total")
- (display-diff-stat "marked" #f this-marked last-marked "cells")
- (display-diff-stat "swept" #f this-swept last-swept "cells")
- (newline))
- ;; GC time taken
- (let ((this-mark (assq-ref this-gcs 'gc-mark-time-taken))
- (last-mark (assq-ref last-gcs 'gc-mark-time-taken))
- (this-sweep (assq-ref this-gcs 'gc-sweep-time-taken))
- (last-sweep (assq-ref last-gcs 'gc-sweep-time-taken))
- (this-total (assq-ref this-gcs 'gc-time-taken))
- (last-total (assq-ref last-gcs 'gc-time-taken)))
- (display-stat-title "GC time taken:" "diff" "total")
- (display-time-stat "mark" this-mark last-mark)
- (display-time-stat "sweep" this-sweep last-sweep)
- (display-time-stat "total" this-total last-total)
- (newline))
- ;; Process time spent
- (let ((this-utime (tms:utime this-tms))
- (last-utime (tms:utime last-tms))
- (this-stime (tms:stime this-tms))
- (last-stime (tms:stime last-tms))
- (this-cutime (tms:cutime this-tms))
- (last-cutime (tms:cutime last-tms))
- (this-cstime (tms:cstime this-tms))
- (last-cstime (tms:cstime last-tms)))
- (display-stat-title "Process time spent:" "diff" "total")
- (display-time-stat "user" this-utime last-utime)
- (display-time-stat "system" this-stime last-stime)
- (display-time-stat "child user" this-cutime last-cutime)
- (display-time-stat "child system" this-cstime last-cstime)
- (newline))
- ;; VM statistics
- (let ((this-time (vms:time this-vms))
- (last-time (vms:time last-vms))
- (this-clock (vms:clock this-vms))
- (last-clock (vms:clock last-vms)))
- (display-stat-title "VM statistics:" "diff" "total")
- (display-time-stat "time spent" this-time last-time)
- (display-diff-stat "bogoclock" #f this-clock last-clock "clock")
- (display-mips-stat "bogomips" this-time this-clock last-time last-clock)
- (newline))
- ;; Save statistics
- ;; Save statistics
- (set! repl.tm-stats this-tms)
- (set! repl.vm-stats this-vms)
- (set! repl.gc-stats this-gcs)))
-
-;;; repl.scm ends here
+(load "command.gsm")
diff --git a/module/system/vm/assemble.scm b/module/system/vm/assemble.scm
index 0c394b76b..59e80d85c 100644
--- a/module/system/vm/assemble.scm
+++ b/module/system/vm/assemble.scm
@@ -278,8 +278,8 @@
(define (code-finalize code)
(match code
((inst (? symbol? s))
- (let ((str (symbol->string s)))
- `(,inst ,(string-length str) ,str)))
+ (let ((s (symbol->string s)))
+ `(,inst ,(string-length s) ,s)))
((inst (? string? s))
`(,inst ,(string-length s) ,s))
(else (code-pack code))))
diff --git a/module/system/vm/conv.scm b/module/system/vm/conv.scm
index 31993d2ac..4e983dc86 100644
--- a/module/system/vm/conv.scm
+++ b/module/system/vm/conv.scm
@@ -70,6 +70,12 @@
(let dump! ((x x))
(cond
((object->code x) => push-code!)
+ ((integer? x)
+ (let ((str (do ((n x (quotient n 256))
+ (l '() (cons (modulo n 256) l)))
+ ((= n 0)
+ (list->string (map integer->char l))))))
+ (push-code! `(load-integer ,str))))
((string? x)
(push-code! `(load-string ,x)))
((symbol? x)
diff --git a/module/system/vm/load.scm b/module/system/vm/load.scm
index 173a5c45e..eba8d4d74 100644
--- a/module/system/vm/load.scm
+++ b/module/system/vm/load.scm
@@ -32,7 +32,7 @@
(compiled (object-file-name file)))
(if (or (not (file-exists? compiled))
(> (stat:mtime (stat file)) (stat:mtime (stat compiled))))
- (compile-file-in file #f (lookup-language 'r5rs)))
+ (compile-file-in file #f (lookup-language 'gscheme)))
(let ((bytes (make-uniform-vector (stat:size (stat compiled)) #\a)))
(call-with-input-file compiled
(lambda (p) (uniform-vector-read! bytes p)))
diff --git a/src/vm_engine.h b/src/vm_engine.h
index 6d4f41391..646be661b 100644
--- a/src/vm_engine.h
+++ b/src/vm_engine.h
@@ -228,8 +228,6 @@ do { \
*/
#define FETCH() (*ip++)
-#define FETCH2() (((int) FETCH () << 8) + (int) FETCH ())
-
#define FETCH_LENGTH(len) do { ip = vm_fetch_length (ip, &len); } while (0)
#undef CLOCK
diff --git a/src/vm_loader.c b/src/vm_loader.c
index c83048438..a25abc7a0 100644
--- a/src/vm_loader.c
+++ b/src/vm_loader.c
@@ -44,10 +44,18 @@
VM_DEFINE_INSTRUCTION (load_integer, "load-integer", -1)
{
size_t len;
+
FETCH_LENGTH (len);
- SCM_MISC_ERROR ("Not implemented yet", SCM_EOL);
- ip += len;
- NEXT;
+ if (len <= 4)
+ {
+ long val = 0;
+ while (len-- > 0)
+ val = (val << 8) + FETCH ();
+ PUSH (scm_long2num (val));
+ NEXT;
+ }
+ else
+ SCM_MISC_ERROR ("load-integer: not implemented yet", SCM_EOL);
}
VM_DEFINE_INSTRUCTION (load_symbol, "load-symbol", -1)
diff --git a/src/vm_system.c b/src/vm_system.c
index 3a4431e55..6c8f86228 100644
--- a/src/vm_system.c
+++ b/src/vm_system.c
@@ -128,7 +128,9 @@ VM_DEFINE_INSTRUCTION (make_int8_1, "make-int8:1", 0)
VM_DEFINE_INSTRUCTION (make_int16, "make-int16", 2)
{
- PUSH (SCM_MAKINUM ((signed short) FETCH2 ()));
+ int h = FETCH ();
+ int l = FETCH ();
+ PUSH (SCM_MAKINUM ((signed short) (h << 8) + l));
NEXT;
}
@@ -168,12 +170,6 @@ VM_DEFINE_INSTRUCTION (object_ref, "object-ref", 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (object_ref_2, "object-ref*2", 2)
-{
- PUSH (OBJECT_REF (FETCH2 ()));
- NEXT;
-}
-
VM_DEFINE_INSTRUCTION (local_ref, "local-ref", 1)
{
PUSH (LOCAL_REF (FETCH ()));
@@ -186,12 +182,6 @@ VM_DEFINE_INSTRUCTION (local_ref_0, "local-ref:0", 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (local_ref_2, "local-ref*2", 2)
-{
- PUSH (LOCAL_REF (FETCH2 ()));
- NEXT;
-}
-
VM_DEFINE_INSTRUCTION (external_ref, "external-ref", 1)
{
unsigned int i;
@@ -216,20 +206,6 @@ VM_DEFINE_INSTRUCTION (module_ref, "module-ref", 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (module_ref_2, "module-ref*2", 2)
-{
- int i = FETCH2 ();
- SCM o, x = OBJECT_REF (i);
- o = VARIABLE_REF (x);
- if (SCM_UNBNDP (o))
- {
- err_args = SCM_LIST1 (SCM_CAR (x));
- goto vm_error_unbound;
- }
- PUSH (o);
- NEXT;
-}
-
VM_DEFINE_INSTRUCTION (variable_ref, "variable-ref", 0)
{
SCM x = *sp;
@@ -252,13 +228,6 @@ VM_DEFINE_INSTRUCTION (local_set, "local-set", 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (local_set_2, "local-set*2", 2)
-{
- LOCAL_SET (FETCH2 (), *sp);
- DROP ();
- NEXT;
-}
-
VM_DEFINE_INSTRUCTION (external_set, "external-set", 1)
{
unsigned int i;
@@ -279,15 +248,6 @@ VM_DEFINE_INSTRUCTION (module_set, "module-set", 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (module_set_2, "module-set*2", 2)
-{
- int i = FETCH2 ();
- SCM x = OBJECT_REF (i);
- VARIABLE_SET (x, *sp);
- DROP ();
- NEXT;
-}
-
VM_DEFINE_INSTRUCTION (variable_set, "variable-set", 0)
{
VARIABLE_SET (sp[0], sp[1]);