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

*** empty log message ***

Browse source
This commit is contained in:
Keisuke Nishida 2001-04-05 01:38:38 +00:00
parent 4ee5686f6c
commit ea9b4b29f3
13 changed files with 684 additions and 529 deletions
Download patch file Download diff file Expand all files Collapse all files

33
module/language/elisp/spec.scm Normal file
View file

@ -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
)

45
module/language/elisp/translate.scm Normal file
View file

@ -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))))

90
module/language/gscheme/spec.scm Normal file
View file

@ -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
)

8
module/language/r5rs/translate.scm
View file

@ -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))

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

@ -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)))))

488
module/system/repl/command.gsm Normal file
View file

@ -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)))

473
module/system/repl/command.scm
View file

@ -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")

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

@ -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))))

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

@ -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)

2
module/system/vm/load.scm
View file

@ -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)))

2
src/vm_engine.h
View file

@ -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

14
src/vm_loader.c
View file

@ -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)

46
src/vm_system.c
View file

@ -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]);