diff options
Diffstat (limited to 'module/system/repl/command.scm')
| -rw-r--r-- | module/system/repl/command.scm | 450 |
1 files changed, 450 insertions, 0 deletions
diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm new file mode 100644 index 000000000..e3abe240a --- /dev/null +++ b/module/system/repl/command.scm @@ -0,0 +1,450 @@ +;;; 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-module (system repl command) + :use-syntax (system base syntax) + :use-module (system base pmatch) + :use-module (system base compile) + :use-module (system repl common) + :use-module (system vm core) + :autoload (system base language) (lookup-language) + :autoload (system il glil) (pprint-glil) + :autoload (system vm disasm) (disassemble-program disassemble-objcode) + :autoload (system vm debug) (vm-debugger vm-backtrace) + :autoload (system vm trace) (vm-trace vm-trace-on vm-trace-off) + :autoload (system vm profile) (vm-profile) + :use-module (ice-9 format) + :use-module (ice-9 session) + :use-module (ice-9 documentation) + :use-module (ice-9 and-let-star) + :export (meta-command)) + + +;;; +;;; Meta command interface +;;; + +(define *command-table* + '((help (help h) (apropos a) (describe d) (option o) (quit q)) + (module (module m) (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 (gc) (statistics stat)))) + +(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 (reverse! opts))))) + (user-error "Unknown meta command: ~A" key)))))))) + + +;;; +;;; Help commands +;;; + +(define (help repl . args) + "help [GROUP] +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 ;)" + (pmatch 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 "Type `,COMMAND -h' to show documentation of each command.") + (newline)) + ((all) + (for-each display-group *command-table*)) + ((,group) (guard (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 REGEXP +Find bindings/modules/packages." + (guile:apropos (->string regexp))) + +(define (describe repl obj) + "describe OBJ +Show description/documentation." + (display (object-documentation (repl-eval repl obj))) + (newline)) + +(define (option repl . args) + "option [KEY VALUE] +List/show/set options." + (pmatch args + (() + (for-each (lambda (key+val) + (format #t "~A\t~A\n" (car key+val) (cdr key+val))) + (repl-options repl))) + ((,key) + (display (repl-option-ref repl key)) + (newline)) + ((,key ,val) + (repl-option-set! repl key val) + (case key + ((trace) + (let ((vm (repl-vm repl))) + (if val + (apply vm-trace-on vm val) + (vm-trace-off vm)))))))) + +(define (quit repl) + "quit +Quit this session." + (throw 'quit)) + + +;;; +;;; Module commands +;;; + +(define (module repl . args) + "module [MODULE] +Change modules / Show current module." + (pmatch args + (() (puts (module-name (current-module)))) + ((,mod-name) (set-current-module (resolve-module mod-name))))) + +(define (import repl . args) + "import [MODULE ...] +Import modules / List those imported." + (let () + (define (use name) + (let ((mod (resolve-interface name))) + (if mod + (module-use! (current-module) mod) + (user-error "No such module: ~A" name)))) + (if (null? args) + (for-each puts (map module-name (module-uses (current-module)))) + (for-each use args)))) + +(define (load repl file . opts) + "load FILE +Load a file in the current module. + + -f Load source file (see `compile')" + (let* ((file (->string file)) + (objcode (if (memq :f opts) + (apply load-source-file file opts) + (apply load-file file opts)))) + (vm-load (repl-vm repl) objcode))) + +(define (binding repl . opts) + "binding +List current bindings." + (module-for-each (lambda (k v) (format #t "~23A ~A\n" k v)) + (current-module))) + + +;;; +;;; Language commands +;;; + +(define (language repl name) + "language LANGUAGE +Change languages." + (set! (repl-language repl) (lookup-language name)) + (repl-welcome repl)) + + +;;; +;;; Compile commands +;;; + +(define (compile repl form . opts) + "compile FORM +Generate compiled code. + + -e Stop after expanding syntax/macro + -t Stop after translating into GHIL + -c Stop after generating GLIL + + -O Enable optimization + -D Add debug information" + (let ((x (apply repl-compile repl form opts))) + (cond ((or (memq :e opts) (memq :t opts)) (puts x)) + ((memq :c opts) (pprint-glil x)) + (else (disassemble-objcode x))))) + +(define guile:compile-file compile-file) +(define (compile-file repl file . opts) + "compile-file FILE +Compile a file." + (apply guile:compile-file (->string file) opts)) + +(define (disassemble repl prog) + "disassemble PROGRAM +Disassemble a program." + (disassemble-program (repl-eval repl prog))) + +(define (disassemble-file repl file) + "disassemble-file FILE +Disassemble a file." + (disassemble-objcode (load-objcode (->string file)))) + + +;;; +;;; Profile commands +;;; + +(define (time repl form) + "time FORM +Time execution." + (let* ((vms-start (vm-stats (repl-vm repl))) + (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 repl)))) + (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) + (repl-compile repl form) + opts)) + + +;;; +;;; Debug commands +;;; + +(define (backtrace repl) + "backtrace +Display backtrace." + (vm-backtrace (repl-vm repl))) + +(define (debugger repl) + "debugger +Start debugger." + (vm-debugger (repl-vm repl))) + +(define (trace 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-vm repl) (repl-compile repl form) opts)) + +(define (step repl) + "step FORM +Step execution." + (display "Not implemented yet\n")) + + +;;; +;;; System commands +;;; + +(define guile:gc gc) +(define (gc repl) + "gc +Garbage collection." + (guile:gc)) + +(define (statistics repl) + "statistics +Display statistics." + (let ((this-tms (times)) + (this-vms (vm-stats (repl-vm repl))) + (this-gcs (gc-stats)) + (last-tms (repl-tm-stats repl)) + (last-vms (repl-vm-stats repl)) + (last-gcs (repl-gc-stats repl))) + ;; 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 repl) this-tms) + (set! (repl-vm-stats repl) this-vms) + (set! (repl-gc-stats repl) this-gcs))) + +(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")) |