diff options
author | Keisuke Nishida <kxn30@po.cwru.edu> | 2001-04-05 01:38:38 +0000 |
---|---|---|
committer | Keisuke Nishida <kxn30@po.cwru.edu> | 2001-04-05 01:38:38 +0000 |
commit | ea9b4b29f39cdc3e17222f0c35462d29c80a6089 (patch) | |
tree | 091e38e3fea3c139f92c554c9b37799590700348 | |
parent | 4ee5686f6cc16cc78df4eecb10eab25268e74835 (diff) | |
download | guile-ea9b4b29f39cdc3e17222f0c35462d29c80a6089.tar.gz |
*** empty log message ***
-rw-r--r-- | module/language/elisp/spec.scm | 33 | ||||
-rw-r--r-- | module/language/elisp/translate.scm | 45 | ||||
-rw-r--r-- | module/language/gscheme/spec.scm | 90 | ||||
-rw-r--r-- | module/language/r5rs/translate.scm | 8 | ||||
-rw-r--r-- | module/system/il/compile.scm | 2 | ||||
-rw-r--r-- | module/system/repl/command.gsm | 488 | ||||
-rw-r--r-- | module/system/repl/command.scm | 473 | ||||
-rw-r--r-- | module/system/vm/assemble.scm | 4 | ||||
-rw-r--r-- | module/system/vm/conv.scm | 6 | ||||
-rw-r--r-- | module/system/vm/load.scm | 2 | ||||
-rw-r--r-- | src/vm_engine.h | 2 | ||||
-rw-r--r-- | src/vm_loader.c | 14 | ||||
-rw-r--r-- | src/vm_system.c | 46 |
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]); |