mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
*** empty log message ***
This commit is contained in:
Keisuke Nishida
parent
15df344720
commit
4bfb26f58f
9 changed files with 595 additions and 560 deletions
|
|
@ -1,483 +0,0 @@
|
||||||
;;; 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
|
|
||||||
|
|
||||||
-O Enable optimization
|
|
||||||
-D Add debug information"
|
|
||||||
(let ((x (apply repl-compile repl form opts)))
|
|
||||||
(cond ((null? 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-eval 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)))
|
|
||||||
|
|
@ -35,4 +35,464 @@
|
||||||
:use-module (ice-9 debugger)
|
:use-module (ice-9 debugger)
|
||||||
:export (meta-command))
|
:export (meta-command))
|
||||||
|
|
||||||
(load "command.gs")
|
(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
|
||||||
|
|
||||||
|
-O Enable optimization
|
||||||
|
-D Add debug information"
|
||||||
|
(let ((x (apply repl-compile repl form opts)))
|
||||||
|
(cond ((null? opts)
|
||||||
|
(disassemble-bootcode 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-eval repl prog)))
|
||||||
|
|
||||||
|
(define (disassemble-file repl file)
|
||||||
|
"disassemble-file FILE
|
||||||
|
Disassemble a file."
|
||||||
|
(disassemble-bootcode
|
||||||
|
(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)))
|
||||||
|
|
|
||||||
|
|
@ -30,7 +30,7 @@
|
||||||
:export (assemble))
|
:export (assemble))
|
||||||
|
|
||||||
(define (assemble glil env . opts)
|
(define (assemble glil env . opts)
|
||||||
(optimizing-dump (codegen (preprocess glil #f) #t)))
|
(codegen (preprocess glil #f) #t))
|
||||||
|
|
||||||
|
|
||||||
;;;
|
;;;
|
||||||
|
|
@ -147,24 +147,29 @@
|
||||||
;;
|
;;
|
||||||
;; main
|
;; main
|
||||||
(for-each generate-code body)
|
(for-each generate-code body)
|
||||||
(let ((bytes (apply string-append (stack-finalize (reverse! stack))))
|
(let ((bytes (stack->bytes stack))
|
||||||
(objs (map car (reverse! object-alist))))
|
(objs (map car (reverse! object-alist))))
|
||||||
(make-bytespec nargs nrest nlocs nexts bytes objs))))))
|
(if toplevel
|
||||||
|
(make-bootcode nlocs nexts bytes)
|
||||||
|
(make-bytespec nargs nrest nlocs nexts bytes objs)))))))
|
||||||
|
|
||||||
(define (stack-finalize stack)
|
(define (stack->bytes stack)
|
||||||
(let loop ((list '()) (stack stack) (addr 0))
|
(let loop ((result '()) (stack (reverse! stack)) (addr 0))
|
||||||
(if (null? stack)
|
(if (null? stack)
|
||||||
(reverse! list)
|
(apply string-append (reverse! result))
|
||||||
(let* ((orig (car stack))
|
(let* ((orig (car stack))
|
||||||
(addr (+ addr (length orig)))
|
(addr (+ addr (length orig)))
|
||||||
(code (if (and (pair? (cdr orig)) (procedure? (cadr orig)))
|
(code (if (and (pair? (cdr orig)) (procedure? (cadr orig)))
|
||||||
`(,(car orig) ,((cadr orig) addr))
|
`(,(car orig) ,((cadr orig) addr))
|
||||||
orig)))
|
orig)))
|
||||||
(loop (cons (code->bytes code) list) (cdr stack) addr)))))
|
(loop (cons (code->bytes code) result) (cdr stack) addr)))))
|
||||||
|
|
||||||
;; Optimization
|
|
||||||
|
;;;
|
||||||
|
;;; Bytecode optimization
|
||||||
|
;;;
|
||||||
|
|
||||||
(define *optimize-table*
|
(define *optimization-table*
|
||||||
'((not (not . not-not)
|
'((not (not . not-not)
|
||||||
(eq? . not-eq?)
|
(eq? . not-eq?)
|
||||||
(null? . not-null?)
|
(null? . not-null?)
|
||||||
|
|
@ -185,53 +190,48 @@
|
||||||
(not-null? . br-if-null))))
|
(not-null? . br-if-null))))
|
||||||
|
|
||||||
(define (optimizing-push code stack)
|
(define (optimizing-push code stack)
|
||||||
(let ((alist (assq-ref *optimize-table* (car code))))
|
(let ((alist (assq-ref *optimization-table* (car code))))
|
||||||
(cond ((and alist (pair? stack) (assq-ref alist (caar stack))) =>
|
(cond ((and alist (pair? stack) (assq-ref alist (caar stack))) =>
|
||||||
(lambda (inst) (cons (cons inst (cdr code)) (cdr stack))))
|
(lambda (inst) (cons (cons inst (cdr code)) (cdr stack))))
|
||||||
(else (cons (code-pack code) stack)))))
|
(else (cons (code-pack code) stack)))))
|
||||||
|
|
||||||
|
|
||||||
;;;
|
;;;
|
||||||
;;; Stage3: Dump optimization
|
;;; Object dump
|
||||||
;;;
|
;;;
|
||||||
|
|
||||||
(define (optimizing-dump bytespec)
|
;; NOTE: undumpped in vm_load.c.
|
||||||
;; no optimization yet
|
|
||||||
(bytespec-bytes bytespec))
|
|
||||||
|
|
||||||
(define (dump-object! x push-code!)
|
(define (dump-object! x push-code!)
|
||||||
(let dump! ((x x))
|
(let dump! ((x x))
|
||||||
(cond
|
(cond
|
||||||
((object->code x) => push-code!)
|
((object->code x) => push-code!)
|
||||||
((bytespec? x)
|
((bytespec? x)
|
||||||
(let ((nargs (bytespec-nargs x))
|
(match x
|
||||||
(nrest (bytespec-nrest x))
|
(($ bytespec nargs nrest nlocs nexts bytes objs)
|
||||||
(nlocs (bytespec-nlocs x))
|
;; dump parameters
|
||||||
(nexts (bytespec-nexts x))
|
(cond
|
||||||
(bytes (bytespec-bytes x))
|
((and (< nargs 4) (< nlocs 8) (< nexts 4))
|
||||||
(objs (bytespec-objs x)))
|
;; 8-bit representation
|
||||||
;; dump parameters
|
(let ((x (+ (* nargs 64) (* nrest 32) (* nlocs 4) nexts)))
|
||||||
(cond ((and (< nargs 4) (< nlocs 8) (< nexts 4))
|
(push-code! `(make-int8 ,x))))
|
||||||
;; 8-bit representation
|
((and (< nargs 16) (< nlocs 128) (< nexts 16))
|
||||||
(let ((x (+ (* nargs 64) (* nrest 32) (* nlocs 4) nexts)))
|
;; 16-bit representation
|
||||||
(push-code! `(make-int8 ,x))))
|
(let ((x (+ (* nargs 4096) (* nrest 2048) (* nlocs 16) nexts)))
|
||||||
((and (< nargs 16) (< nlocs 128) (< nexts 16))
|
(push-code! `(make-int16 ,(quotient x 256) ,(modulo x 256)))))
|
||||||
;; 16-bit representation
|
(else
|
||||||
(let ((x (+ (* nargs 4096) (* nrest 2048) (* nlocs 16) nexts)))
|
;; Other cases
|
||||||
(push-code! `(make-int16 ,(quotient x 256) ,(modulo x 256)))))
|
(push-code! (object->code nargs))
|
||||||
(else
|
(push-code! (object->code nrest))
|
||||||
;; Other cases
|
(push-code! (object->code nlocs))
|
||||||
(push-code! (object->code nargs))
|
(push-code! (object->code nexts))
|
||||||
(push-code! (object->code nrest))
|
(push-code! (object->code #f))))
|
||||||
(push-code! (object->code nlocs))
|
;; dump object table
|
||||||
(push-code! (object->code nexts))
|
(cond ((not (null? objs))
|
||||||
(push-code! (object->code #f))))
|
(for-each dump! objs)
|
||||||
;; dump object table
|
(push-code! `(vector ,(length objs)))))
|
||||||
(cond ((not (null? objs))
|
;; dump bytecode
|
||||||
(for-each dump! objs)
|
(push-code! `(load-program ,bytes)))))
|
||||||
(push-code! `(vector ,(length objs)))))
|
|
||||||
;; dump bytecode
|
|
||||||
(push-code! `(load-program ,bytes))))
|
|
||||||
((vlink? x)
|
((vlink? x)
|
||||||
;; (push-code! `(local-ref ,(object-index (vlink-module x))))
|
;; (push-code! `(local-ref ,(object-index (vlink-module x))))
|
||||||
(dump! (vlink-name x))
|
(dump! (vlink-name x))
|
||||||
|
|
@ -264,10 +264,3 @@
|
||||||
(push-code! `(vector ,(vector-length x))))
|
(push-code! `(vector ,(vector-length x))))
|
||||||
(else
|
(else
|
||||||
(error "Cannot dump:" x)))))
|
(error "Cannot dump:" x)))))
|
||||||
|
|
||||||
;;;(define (dump-table-object! obj+index)
|
|
||||||
;;; (let dump! ((x (car obj+index)))
|
|
||||||
;;; (cond
|
|
||||||
;;; (else
|
|
||||||
;;; (for-each push-code! (dump-object! x)))))
|
|
||||||
;;; (push-code! `(local-set ,(cdr obj+index))))
|
|
||||||
|
|
|
||||||
|
|
@ -131,9 +131,11 @@
|
||||||
|
|
||||||
|
|
||||||
;;;
|
;;;
|
||||||
;;; Variable-length code
|
;;; Variable-length interface
|
||||||
;;;
|
;;;
|
||||||
|
|
||||||
|
;; NOTE: decoded in vm_fetch_length in vm.c.
|
||||||
|
|
||||||
(define (encode-length len)
|
(define (encode-length len)
|
||||||
(define C integer->char)
|
(define C integer->char)
|
||||||
(cond ((< len 254) (string (C len)))
|
(cond ((< len 254) (string (C len)))
|
||||||
|
|
|
||||||
|
|
@ -21,14 +21,60 @@
|
||||||
|
|
||||||
(define-module (system vm core))
|
(define-module (system vm core))
|
||||||
|
|
||||||
|
;;;
|
||||||
|
;;; Core procedures
|
||||||
|
;;;
|
||||||
|
|
||||||
(dynamic-call "scm_init_vm" (dynamic-link "libguilevm.so"))
|
(dynamic-call "scm_init_vm" (dynamic-link "libguilevm.so"))
|
||||||
|
|
||||||
(export vms:cons vms:time vms:clock)
|
|
||||||
|
|
||||||
(define (vms:time stat) (vector-ref stat 0))
|
|
||||||
(define (vms:clock stat) (vector-ref stat 1))
|
|
||||||
|
|
||||||
(module-export! (current-module)
|
(module-export! (current-module)
|
||||||
(delq! '%module-public-interface
|
(delq! '%module-public-interface
|
||||||
(hash-fold (lambda (k v d) (cons k d)) '()
|
(hash-fold (lambda (k v d) (cons k d)) '()
|
||||||
(module-obarray (current-module)))))
|
(module-obarray (current-module)))))
|
||||||
|
|
||||||
|
;;;
|
||||||
|
;;; Bootcode interface
|
||||||
|
;;;
|
||||||
|
|
||||||
|
(export make-bootcode bootcode? bootcode-version
|
||||||
|
bootcode-nlocs bootcode-nexts bootcode-bytecode)
|
||||||
|
|
||||||
|
(define *bootcode-cookie* (string-append "\0GBC-" (vm-version)))
|
||||||
|
|
||||||
|
(define (make-bootcode nlocs nexts bytes)
|
||||||
|
(string-append *bootcode-cookie*
|
||||||
|
(integer->bytes nlocs)
|
||||||
|
(integer->bytes nexts)
|
||||||
|
bytes))
|
||||||
|
|
||||||
|
(define (bootcode? x)
|
||||||
|
(and (string? x)
|
||||||
|
(> (string-length x) 10)
|
||||||
|
(string=? (substring x 1 4) "GBC")))
|
||||||
|
|
||||||
|
(define (bootcode-version x)
|
||||||
|
(substring x 5 8))
|
||||||
|
|
||||||
|
(define (bootcode-nlocs x)
|
||||||
|
(bytes->integer x 8))
|
||||||
|
|
||||||
|
(define (bootcode-nexts x)
|
||||||
|
(bytes->integer x 9))
|
||||||
|
|
||||||
|
(define (bootcode-bytecode x)
|
||||||
|
(substring x 10))
|
||||||
|
|
||||||
|
(define (integer->bytes n)
|
||||||
|
(string (integer->char n)))
|
||||||
|
|
||||||
|
(define (bytes->integer bytes start)
|
||||||
|
(char->integer (string-ref bytes start)))
|
||||||
|
|
||||||
|
;;;
|
||||||
|
;;; Statistics interface
|
||||||
|
;;;
|
||||||
|
|
||||||
|
(export vms:time vms:clock)
|
||||||
|
|
||||||
|
(define (vms:time stat) (vector-ref stat 0))
|
||||||
|
(define (vms:clock stat) (vector-ref stat 1))
|
||||||
|
|
|
||||||
|
|
@ -27,18 +27,28 @@
|
||||||
:use-module (ice-9 format)
|
:use-module (ice-9 format)
|
||||||
:use-module (ice-9 receive)
|
:use-module (ice-9 receive)
|
||||||
:use-module (ice-9 and-let-star)
|
:use-module (ice-9 and-let-star)
|
||||||
:export (disassemble-program disassemble-bytecode))
|
:export (disassemble-bootcode disassemble-program))
|
||||||
|
|
||||||
|
(define (disassemble-bootcode bytes . opts)
|
||||||
|
(if (not (bootcode? bytes)) (error "Invalid bootcode"))
|
||||||
|
(format #t "Disassembly of bootcode:\n\n")
|
||||||
|
(format #t "Compiled for Guile VM ~A\n\n" (bootcode-version bytes))
|
||||||
|
(format #t "nlocs = ~A nexts = ~A\n\n"
|
||||||
|
(bootcode-nlocs bytes) (bootcode-nexts bytes))
|
||||||
|
(disassemble-bytecode (bootcode-bytecode bytes) #f))
|
||||||
|
|
||||||
(define (disassemble-program prog . opts)
|
(define (disassemble-program prog . opts)
|
||||||
(let* ((arity (program-arity prog))
|
(let* ((arity (program-arity prog))
|
||||||
(nargs (car arity))
|
(nargs (car arity))
|
||||||
(nrest (cadr arity))
|
(nrest (cadr arity))
|
||||||
(nlocs (caddr arity))
|
(nlocs (caddr arity))
|
||||||
|
(nexts (cadddr arity))
|
||||||
(bytes (program-bytecode prog))
|
(bytes (program-bytecode prog))
|
||||||
(objs (program-objects prog)))
|
(objs (program-objects prog)))
|
||||||
;; Disassemble this bytecode
|
;; Disassemble this bytecode
|
||||||
(format #t "Disassembly of ~A:\n\n" prog)
|
(format #t "Disassembly of ~A:\n\n" prog)
|
||||||
(format #t "args = ~A rest = ~A locals = ~A\n\n" nargs nrest nlocs)
|
(format #t "nargs = ~A nrest = ~A nlocs = ~A nexts ~A\n\n"
|
||||||
|
nargs nrest nlocs nexts)
|
||||||
(format #t "Bytecode:\n\n")
|
(format #t "Bytecode:\n\n")
|
||||||
(disassemble-bytecode bytes objs)
|
(disassemble-bytecode bytes objs)
|
||||||
(if (> (vector-length objs) 0)
|
(if (> (vector-length objs) 0)
|
||||||
|
|
@ -51,7 +61,7 @@
|
||||||
(apply disassemble-program x opts))))
|
(apply disassemble-program x opts))))
|
||||||
(vector->list objs))))
|
(vector->list objs))))
|
||||||
|
|
||||||
(define (disassemble-bytecode bytes . opt)
|
(define (disassemble-bytecode bytes objs)
|
||||||
(let ((decode (make-byte-decoder bytes))
|
(let ((decode (make-byte-decoder bytes))
|
||||||
(rest '()))
|
(rest '()))
|
||||||
(do ((addr+code (decode) (decode)))
|
(do ((addr+code (decode) (decode)))
|
||||||
|
|
@ -64,12 +74,11 @@
|
||||||
(print-info addr (format #f "load-program #~A" sym) #f)))
|
(print-info addr (format #f "load-program #~A" sym) #f)))
|
||||||
(else
|
(else
|
||||||
(let ((info (list->info code))
|
(let ((info (list->info code))
|
||||||
(extra (original-value addr code
|
(extra (original-value addr code objs)))
|
||||||
(if (null? opt) #f (car opt)))))
|
|
||||||
(print-info addr info extra))))))
|
(print-info addr info extra))))))
|
||||||
(for-each (lambda (sym+bytes)
|
(for-each (lambda (sym+bytes)
|
||||||
(format #t "Bytecode #~A:\n\n" (car sym+bytes))
|
(format #t "Bytecode #~A:\n\n" (car sym+bytes))
|
||||||
(disassemble-bytecode (cdr sym+bytes)))
|
(disassemble-bytecode (cdr sym+bytes) #f))
|
||||||
(reverse! rest))))
|
(reverse! rest))))
|
||||||
|
|
||||||
(define (disassemble-objects objs)
|
(define (disassemble-objects objs)
|
||||||
|
|
|
||||||
|
|
@ -119,18 +119,12 @@ static int
|
||||||
program_print (SCM obj, SCM port, scm_print_state *pstate)
|
program_print (SCM obj, SCM port, scm_print_state *pstate)
|
||||||
{
|
{
|
||||||
SCM name = scm_object_property (obj, scm_sym_name);
|
SCM name = scm_object_property (obj, scm_sym_name);
|
||||||
|
scm_puts ("#<program ", port);
|
||||||
if (SCM_FALSEP (name))
|
if (SCM_FALSEP (name))
|
||||||
{
|
scm_intprint ((long) SCM_PROGRAM_BASE (obj), 16, port);
|
||||||
scm_puts ("#<program 0x", port);
|
|
||||||
scm_intprint ((long) SCM_PROGRAM_BASE (obj), 16, port);
|
|
||||||
scm_putc ('>', port);
|
|
||||||
}
|
|
||||||
else
|
else
|
||||||
{
|
scm_display (name, port);
|
||||||
scm_puts ("#<program ", port);
|
scm_putc ('>', port);
|
||||||
scm_display (name, port);
|
|
||||||
scm_putc ('>', port);
|
|
||||||
}
|
|
||||||
return 1;
|
return 1;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
|
||||||
23
src/vm.c
23
src/vm.c
|
|
@ -203,6 +203,7 @@ SCM_SYMBOL (sym_vm_error, "vm-error");
|
||||||
static scm_byte_t *
|
static scm_byte_t *
|
||||||
vm_fetch_length (scm_byte_t *ip, size_t *lenp)
|
vm_fetch_length (scm_byte_t *ip, size_t *lenp)
|
||||||
{
|
{
|
||||||
|
/* NOTE: format defined in system/vm/conv.scm */
|
||||||
*lenp = *ip++;
|
*lenp = *ip++;
|
||||||
if (*lenp < 254)
|
if (*lenp < 254)
|
||||||
return ip;
|
return ip;
|
||||||
|
|
@ -566,18 +567,30 @@ SCM_DEFINE (scm_vm_fetch_stack, "vm-fetch-stack", 1, 0, 0,
|
||||||
#undef FUNC_NAME
|
#undef FUNC_NAME
|
||||||
|
|
||||||
SCM_DEFINE (scm_vm_load, "vm-load", 2, 0, 0,
|
SCM_DEFINE (scm_vm_load, "vm-load", 2, 0, 0,
|
||||||
(SCM vm, SCM bytes),
|
(SCM vm, SCM bootcode),
|
||||||
"")
|
"")
|
||||||
#define FUNC_NAME s_scm_vm_load
|
#define FUNC_NAME s_scm_vm_load
|
||||||
{
|
{
|
||||||
SCM prog;
|
SCM prog;
|
||||||
|
int len;
|
||||||
|
char *base;
|
||||||
|
|
||||||
SCM_VALIDATE_VM (1, vm);
|
SCM_VALIDATE_VM (1, vm);
|
||||||
SCM_VALIDATE_STRING (2, bytes);
|
SCM_VALIDATE_STRING (2, bootcode);
|
||||||
|
|
||||||
prog = scm_c_make_program (SCM_STRING_CHARS (bytes),
|
base = SCM_STRING_CHARS (bootcode);
|
||||||
SCM_STRING_LENGTH (bytes),
|
len = SCM_STRING_LENGTH (bootcode);
|
||||||
bytes);
|
|
||||||
|
/* Check bootcode */
|
||||||
|
if (strncmp (base, "\0GBC", 4) != 0)
|
||||||
|
SCM_MISC_ERROR ("Invalid bootcode: ~S", SCM_LIST1 (bootcode));
|
||||||
|
|
||||||
|
/* Create program */
|
||||||
|
prog = scm_c_make_program (base + 10, len - 10, bootcode);
|
||||||
|
SCM_PROGRAM_NLOCS (prog) = base[8];
|
||||||
|
SCM_PROGRAM_NEXTS (prog) = base[9];
|
||||||
|
|
||||||
|
/* Load it */
|
||||||
return scm_vm_apply (vm, prog, SCM_EOL);
|
return scm_vm_apply (vm, prog, SCM_EOL);
|
||||||
}
|
}
|
||||||
#undef FUNC_NAME
|
#undef FUNC_NAME
|
||||||
|
|
|
||||||
|
|
@ -124,6 +124,7 @@ VM_DEFINE_INSTRUCTION (load_program, "load-program", -1, 0, 1)
|
||||||
}
|
}
|
||||||
|
|
||||||
/* init parameters */
|
/* init parameters */
|
||||||
|
/* NOTE: format defined in system/vm/assemble.scm */
|
||||||
if (SCM_INUMP (x))
|
if (SCM_INUMP (x))
|
||||||
{
|
{
|
||||||
int i = SCM_INUM (x);
|
int i = SCM_INUM (x);
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue