diff options
Diffstat (limited to 'module/system')
| -rw-r--r-- | module/system/base/compile.scm | 258 | ||||
| -rw-r--r-- | module/system/base/language.scm | 99 | ||||
| -rw-r--r-- | module/system/base/message.scm | 102 | ||||
| -rw-r--r-- | module/system/base/pmatch.scm | 41 | ||||
| -rw-r--r-- | module/system/base/syntax.scm | 327 | ||||
| -rw-r--r-- | module/system/repl/command.scm | 502 | ||||
| -rw-r--r-- | module/system/repl/common.scm | 112 | ||||
| -rw-r--r-- | module/system/repl/describe.scm | 360 | ||||
| -rw-r--r-- | module/system/repl/repl.scm | 150 | ||||
| -rw-r--r-- | module/system/vm/debug.scm | 62 | ||||
| -rw-r--r-- | module/system/vm/frame.scm | 209 | ||||
| -rw-r--r-- | module/system/vm/instruction.scm | 27 | ||||
| -rw-r--r-- | module/system/vm/objcode.scm | 27 | ||||
| -rw-r--r-- | module/system/vm/profile.scm | 64 | ||||
| -rw-r--r-- | module/system/vm/program.scm | 100 | ||||
| -rw-r--r-- | module/system/vm/trace.scm | 76 | ||||
| -rw-r--r-- | module/system/vm/vm.scm | 41 | ||||
| -rw-r--r-- | module/system/xref.scm | 182 |
18 files changed, 2739 insertions, 0 deletions
diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm new file mode 100644 index 000000000..26dd29e20 --- /dev/null +++ b/module/system/base/compile.scm @@ -0,0 +1,258 @@ +;;; High-level compiler interface + +;; Copyright (C) 2001, 2009 Free Software Foundation, Inc. + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public +;;; License as published by the Free Software Foundation; either +;;; version 3 of the License, or (at your option) any later version. +;;; +;;; This library 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 +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (system base compile) + #:use-module (system base syntax) + #:use-module (system base language) + #:use-module (system base message) + #:use-module (system vm vm) ;; FIXME: there's a reason for this, can't remember why tho + #:use-module (ice-9 regex) + #:use-module (ice-9 optargs) + #:use-module (ice-9 receive) + #:export (syntax-error + *current-language* + compiled-file-name compile-file compile-and-load + compile + decompile) + #:export-syntax (call-with-compile-error-catch)) + +;;; +;;; Compiler environment +;;; + +(define (syntax-error loc msg exp) + (throw 'syntax-error-compile-time loc msg exp)) + +(define-macro (call-with-compile-error-catch thunk) + `(catch 'syntax-error-compile-time + ,thunk + (lambda (key loc msg exp) + (if (pair? loc) + (let ((file (or (assq-ref loc 'filename) "unknown file")) + (line (assq-ref loc 'line)) + (col (assq-ref loc 'column))) + (format (current-error-port) + "~A:~A:~A: ~A: ~A~%" file line col msg exp)) + (format (current-error-port) + "unknown location: ~A: ~S~%" msg exp))))) + + +;;; +;;; Compiler +;;; + +(define *current-language* (make-fluid)) +(fluid-set! *current-language* 'scheme) +(define (current-language) + (fluid-ref *current-language*)) + +(define (call-once thunk) + (let ((entered #f)) + (dynamic-wind + (lambda () + (if entered + (error "thunk may only be entered once: ~a" thunk)) + (set! entered #t)) + thunk + (lambda () #t)))) + +(define* (call-with-output-file/atomic filename proc #:optional reference) + (let* ((template (string-append filename ".XXXXXX")) + (tmp (mkstemp! template))) + (call-once + (lambda () + (with-throw-handler #t + (lambda () + (proc tmp) + (chmod tmp (logand #o0666 (lognot (umask)))) + (close-port tmp) + (if reference + (let ((st (stat reference))) + (utime template (stat:atime st) (stat:mtime st)))) + (rename-file template filename)) + (lambda args + (delete-file template))))))) + +(define (ensure-language x) + (if (language? x) + x + (lookup-language x))) + +;; Throws an exception if `dir' is not writable. The double-stat is OK, +;; as this is only used during compilation. +(define (ensure-writable-dir dir) + (if (file-exists? dir) + (if (access? dir W_OK) + #t + (error "directory not writable" dir)) + (begin + (ensure-writable-dir (dirname dir)) + (mkdir dir)))) + +(define (dsu-sort list key less) + (map cdr + (stable-sort (map (lambda (x) (cons (key x) x)) list) + (lambda (x y) (less (car x) (car y)))))) + +;;; This function is among the trickiest I've ever written. I tried many +;;; variants. In the end, simple is best, of course. +;;; +;;; After turning this around a number of times, it seems that the the +;;; desired behavior is that .go files should exist in a path, for +;;; searching. That is orthogonal to this function. For writing .go +;;; files, either you know where they should go, in which case you tell +;;; compile-file explicitly, as in the srcdir != builddir case; or you +;;; don't know, in which case this function is called, and we just put +;;; them in your own ccache dir in ~/.guile-ccache. +(define (compiled-file-name file) + (define (compiled-extension) + (cond ((or (null? %load-compiled-extensions) + (string-null? (car %load-compiled-extensions))) + (warn "invalid %load-compiled-extensions" + %load-compiled-extensions) + ".go") + (else (car %load-compiled-extensions)))) + (and %compile-fallback-path + (let ((f (string-append + %compile-fallback-path + ;; no need for '/' separator here, canonicalize-path + ;; will give us an absolute path + (canonicalize-path file) + (compiled-extension)))) + (and (false-if-exception (ensure-writable-dir (dirname f))) + f)))) + +(define* (compile-file file #:key + (output-file #f) + (env #f) + (from (current-language)) + (to 'objcode) + (opts '())) + (let* ((comp (or output-file (compiled-file-name file))) + (in (open-input-file file)) + (enc (file-encoding in))) + (if enc + (set-port-encoding! in enc)) + (ensure-writable-dir (dirname comp)) + (call-with-output-file/atomic comp + (lambda (port) + ((language-printer (ensure-language to)) + (read-and-compile in #:env env #:from from #:to to #:opts opts) + port)) + file) + comp)) + +(define* (compile-and-load file #:key (from 'scheme) (to 'value) (opts '())) + (read-and-compile (open-input-file file) + #:from from #:to to #:opts opts)) + + +;;; +;;; Compiler interface +;;; + +(define (compile-passes from to opts) + (map cdr + (or (lookup-compilation-order from to) + (error "no way to compile" from "to" to)))) + +(define (compile-fold passes exp env opts) + (let lp ((passes passes) (x exp) (e env) (cenv env) (first? #t)) + (if (null? passes) + (values x e cenv) + (receive (x e new-cenv) ((car passes) x e opts) + (lp (cdr passes) x e (if first? new-cenv cenv) #f))))) + +(define (find-language-joint from to) + (let lp ((in (reverse (or (lookup-compilation-order from to) + (error "no way to compile" from "to" to)))) + (lang to)) + (cond ((null? in) + (error "don't know how to join expressions" from to)) + ((language-joiner lang) lang) + (else + (lp (cdr in) (caar in)))))) + +(define* (read-and-compile port #:key + (env #f) + (from (current-language)) + (to 'objcode) + (opts '())) + (let ((from (ensure-language from)) + (to (ensure-language to))) + (let ((joint (find-language-joint from to))) + (with-fluids ((*current-language* from)) + (let lp ((exps '()) (env #f) (cenv env)) + (let ((x ((language-reader (current-language)) port))) + (cond + ((eof-object? x) + (compile ((language-joiner joint) (reverse exps) env) + #:from joint #:to to #:env env #:opts opts)) + (else + ;; compile-fold instead of compile so we get the env too + (receive (jexp jenv jcenv) + (compile-fold (compile-passes (current-language) joint opts) + x cenv opts) + (lp (cons jexp exps) jenv jcenv)))))))))) + +(define* (compile x #:key + (env #f) + (from (current-language)) + (to 'value) + (opts '())) + + (let ((warnings (memq #:warnings opts))) + (if (pair? warnings) + (let ((warnings (cadr warnings))) + ;; Sanity-check the requested warnings. + (for-each (lambda (w) + (or (lookup-warning-type w) + (warning 'unsupported-warning #f w))) + warnings)))) + + (receive (exp env cenv) + (compile-fold (compile-passes from to opts) x env opts) + exp)) + + +;;; +;;; Decompiler interface +;;; + +(define (decompile-passes from to opts) + (map cdr + (or (lookup-decompilation-order from to) + (error "no way to decompile" from "to" to)))) + +(define (decompile-fold passes exp env opts) + (if (null? passes) + (values exp env) + (receive (exp env) ((car passes) exp env opts) + (decompile-fold (cdr passes) exp env opts)))) + +(define* (decompile x #:key + (env #f) + (from 'value) + (to 'assembly) + (opts '())) + (decompile-fold (decompile-passes from to opts) + x + env + opts)) diff --git a/module/system/base/language.scm b/module/system/base/language.scm new file mode 100644 index 000000000..3670c53d9 --- /dev/null +++ b/module/system/base/language.scm @@ -0,0 +1,99 @@ +;;; Multi-language support + +;; Copyright (C) 2001, 2009 Free Software Foundation, Inc. + +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 3 of the License, or (at your option) any later version. +;; +;; This library 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 +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +;; 02110-1301 USA + +;;; Code: + +(define-module (system base language) + #:use-module (system base syntax) + #:export (define-language language? lookup-language make-language + language-name language-title language-version language-reader + language-printer language-parser + language-compilers language-decompilers language-evaluator + language-joiner + + lookup-compilation-order lookup-decompilation-order + invalidate-compilation-cache!)) + + +;;; +;;; Language class +;;; + +(define-record/keywords <language> + name + title + version + reader + printer + (parser #f) + (compilers '()) + (decompilers '()) + (evaluator #f) + (joiner #f)) + +(define-macro (define-language name . spec) + `(begin + (invalidate-compilation-cache!) + (define ,name (make-language #:name ',name ,@spec)))) + +(define (lookup-language name) + (let ((m (resolve-module `(language ,name spec)))) + (if (module-bound? m name) + (module-ref m name) + (error "no such language" name)))) + +(define *compilation-cache* '()) +(define *decompilation-cache* '()) + +(define (invalidate-compilation-cache!) + (set! *decompilation-cache* '()) + (set! *compilation-cache* '())) + +(define (compute-translation-order from to language-translators) + (cond + ((not (language? to)) + (compute-translation-order from (lookup-language to) language-translators)) + (else + (let lp ((from from) (seen '())) + (cond + ((not (language? from)) + (lp (lookup-language from) seen)) + ((eq? from to) (reverse! seen)) + ((memq from seen) #f) + (else (or-map (lambda (pair) + (lp (car pair) (acons from (cdr pair) seen))) + (language-translators from)))))))) + +(define (lookup-compilation-order from to) + (let ((key (cons from to))) + (or (assoc-ref *compilation-cache* key) + (let ((order (compute-translation-order from to language-compilers))) + (set! *compilation-cache* + (acons key order *compilation-cache*)) + order)))) + +(define (lookup-decompilation-order from to) + (let ((key (cons from to))) + (or (assoc-ref *decompilation-cache* key) + ;; trickery! + (let ((order (and=> + (compute-translation-order to from language-decompilers) + reverse!))) + (set! *decompilation-cache* (acons key order *decompilation-cache*)) + order)))) diff --git a/module/system/base/message.scm b/module/system/base/message.scm new file mode 100644 index 000000000..6b68c5639 --- /dev/null +++ b/module/system/base/message.scm @@ -0,0 +1,102 @@ +;;; User interface messages + +;; Copyright (C) 2009 Free Software Foundation, Inc. + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public +;;; License as published by the Free Software Foundation; either +;;; version 3 of the License, or (at your option) any later version. +;;; +;;; This library 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 +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; This module provide a simple interface to send messages to the user. +;;; TODO: Internationalize messages. +;;; +;;; Code: + +(define-module (system base message) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:export (*current-warning-port* warning + + warning-type? warning-type-name warning-type-description + warning-type-printer lookup-warning-type + + %warning-types)) + + +;;; +;;; Source location +;;; + +(define (location-string loc) + (if (pair? loc) + (format #f "~a:~a:~a" + (or (assoc-ref loc 'filename) "<stdin>") + (1+ (assoc-ref loc 'line)) + (assoc-ref loc 'column)) + "<unknown-location>")) + + +;;; +;;; Warnings +;;; + +(define *current-warning-port* + ;; The port where warnings are sent. + (make-fluid)) + +(fluid-set! *current-warning-port* (current-error-port)) + +(define-record-type <warning-type> + (make-warning-type name description printer) + warning-type? + (name warning-type-name) + (description warning-type-description) + (printer warning-type-printer)) + +(define %warning-types + ;; List of know warning types. + (map (lambda (args) + (apply make-warning-type args)) + + `((unsupported-warning ;; a "meta warning" + "warn about unknown warning types" + ,(lambda (port unused name) + (format port "warning: unknown warning type `~A'~%" + name))) + + (unused-variable + "report unused variables" + ,(lambda (port loc name) + (format port "~A: warning: unused variable `~A'~%" + loc name)))))) + +(define (lookup-warning-type name) + "Return the warning type NAME or `#f' if not found." + (find (lambda (wt) + (eq? name (warning-type-name wt))) + %warning-types)) + +(define (warning type location . args) + "Emit a warning of type TYPE for source location LOCATION (a source +property alist) using the data in ARGS." + (let ((wt (lookup-warning-type type)) + (port (fluid-ref *current-warning-port*))) + (if (warning-type? wt) + (apply (warning-type-printer wt) + port (location-string location) + args) + (format port "~A: unknown warning type `~A': ~A~%" + (location-string location) type args)))) + +;;; message.scm ends here diff --git a/module/system/base/pmatch.scm b/module/system/base/pmatch.scm new file mode 100644 index 000000000..4777431e5 --- /dev/null +++ b/module/system/base/pmatch.scm @@ -0,0 +1,41 @@ +(define-module (system base pmatch) + #:export (pmatch)) +;; FIXME: shouldn't have to export ppat... + +;; Originally written by Oleg Kiselyov. Taken from: +;; αKanren: A Fresh Name in Nominal Logic Programming +;; by William E. Byrd and Daniel P. Friedman +;; Proceedings of the 2007 Workshop on Scheme and Functional Programming +;; Université Laval Technical Report DIUL-RT-0701 + +;; Licensing unclear. Probably need to ask Oleg for a disclaimer. + +(define-syntax pmatch + (syntax-rules (else guard) + ((_ (op arg ...) cs ...) + (let ((v (op arg ...))) + (pmatch v cs ...))) + ((_ v) (if #f #f)) + ((_ v (else e0 e ...)) (let () e0 e ...)) + ((_ v (pat (guard g ...) e0 e ...) cs ...) + (let ((fk (lambda () (pmatch v cs ...)))) + (ppat v pat + (if (and g ...) (let () e0 e ...) (fk)) + (fk)))) + ((_ v (pat e0 e ...) cs ...) + (let ((fk (lambda () (pmatch v cs ...)))) + (ppat v pat (let () e0 e ...) (fk)))))) + +(define-syntax ppat + (syntax-rules (_ quote unquote) + ((_ v _ kt kf) kt) + ((_ v () kt kf) (if (null? v) kt kf)) + ((_ v (quote lit) kt kf) + (if (equal? v (quote lit)) kt kf)) + ((_ v (unquote var) kt kf) (let ((var v)) kt)) + ((_ v (x . y) kt kf) + (if (pair? v) + (let ((vx (car v)) (vy (cdr v))) + (ppat vx x (ppat vy y kt kf) kf)) + kf)) + ((_ v lit kt kf) (if (eq? v (quote lit)) kt kf)))) diff --git a/module/system/base/syntax.scm b/module/system/base/syntax.scm new file mode 100644 index 000000000..249961d79 --- /dev/null +++ b/module/system/base/syntax.scm @@ -0,0 +1,327 @@ +;;; Guile VM specific syntaxes and utilities + +;; Copyright (C) 2001, 2009 Free Software Foundation, Inc + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public +;;; License as published by the Free Software Foundation; either +;;; version 3 of the License, or (at your option) any later version. +;;; +;;; This library 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 +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (system base syntax) + #:export (%compute-initargs) + #:export-syntax (define-type define-record define-record/keywords + record-case transform-record)) + +(define (symbol-trim-both sym pred) + (string->symbol (string-trim-both (symbol->string sym) pred))) +(define (trim-brackets sym) + (symbol-trim-both sym (list->char-set '(#\< #\>)))) + + +;;; +;;; Type +;;; + +(define-macro (define-type name . rest) + (let ((name (if (pair? name) (car name) name)) + (opts (if (pair? name) (cdr name) '()))) + (let ((printer (kw-arg-ref opts #:printer)) + (common-slots (or (kw-arg-ref opts #:common-slots) '()))) + `(begin ,@(map (lambda (def) + `(define-record ,(if printer + `(,(car def) ,printer) + (car def)) + ,@common-slots + ,@(cdr def))) + rest) + ,@(map (lambda (common-slot i) + `(define ,(symbol-append (trim-brackets name) + '- common-slot) + (make-procedure-with-setter + (lambda (x) (struct-ref x ,i)) + (lambda (x v) (struct-set! x ,i v))))) + common-slots (iota (length common-slots))))))) + + +;;; +;;; Record +;;; + +(define-macro (define-record name-form . slots) + (let* ((name (if (pair? name-form) (car name-form) name-form)) + (printer (and (pair? name-form) (cadr name-form))) + (slot-names (map (lambda (slot) (if (pair? slot) (car slot) slot)) + slots)) + (stem (trim-brackets name))) + `(begin + (define ,name (make-record-type ,(symbol->string name) ',slot-names + ,@(if printer (list printer) '()))) + ,(let* ((reqs (let lp ((slots slots)) + (if (or (null? slots) (not (symbol? (car slots)))) + '() + (cons (car slots) (lp (cdr slots)))))) + (opts (list-tail slots (length reqs))) + (tail (gensym))) + `(define (,(symbol-append 'make- stem) ,@reqs . ,tail) + (let ,(map (lambda (o) + `(,(car o) (cond ((null? ,tail) ,(cadr o)) + (else (let ((_x (car ,tail))) + (set! ,tail (cdr ,tail)) + _x))))) + opts) + (make-struct ,name 0 ,@slot-names)))) + (define ,(symbol-append stem '?) (record-predicate ,name)) + ,@(map (lambda (sname) + `(define ,(symbol-append stem '- sname) + (make-procedure-with-setter + (record-accessor ,name ',sname) + (record-modifier ,name ',sname)))) + slot-names)))) + +;; like the former, but accepting keyword arguments in addition to +;; optional arguments +(define-macro (define-record/keywords name-form . slots) + (let* ((name (if (pair? name-form) (car name-form) name-form)) + (printer (and (pair? name-form) (cadr name-form))) + (slot-names (map (lambda (slot) (if (pair? slot) (car slot) slot)) + slots)) + (stem (trim-brackets name))) + `(begin + (define ,name (make-record-type ,(symbol->string name) ',slot-names + ,@(if printer (list printer) '()))) + (define ,(symbol-append 'make- stem) + (let ((slots (list ,@(map (lambda (slot) + (if (pair? slot) + `(cons ',(car slot) ,(cadr slot)) + `',slot)) + slots))) + (constructor (record-constructor ,name))) + (lambda args + (apply constructor (%compute-initargs args slots))))) + (define ,(symbol-append stem '?) (record-predicate ,name)) + ,@(map (lambda (sname) + `(define ,(symbol-append stem '- sname) + (make-procedure-with-setter + (record-accessor ,name ',sname) + (record-modifier ,name ',sname)))) + slot-names)))) + +(define (%compute-initargs args slots) + (define (finish out) + (map (lambda (slot) + (let ((name (if (pair? slot) (car slot) slot))) + (cond ((assq name out) => cdr) + ((pair? slot) (cdr slot)) + (else (error "unbound slot" args slots name))))) + slots)) + (let lp ((in args) (positional slots) (out '())) + (cond + ((null? in) + (finish out)) + ((keyword? (car in)) + (let ((sym (keyword->symbol (car in)))) + (cond + ((and (not (memq sym slots)) + (not (assq sym (filter pair? slots)))) + (error "unknown slot" sym)) + ((assq sym out) (error "slot already set" sym out)) + (else (lp (cddr in) '() (acons sym (cadr in) out)))))) + ((null? positional) + (error "too many initargs" args slots)) + (else + (lp (cdr in) (cdr positional) + (let ((slot (car positional))) + (acons (if (pair? slot) (car slot) slot) + (car in) + out))))))) + +;; So, dear reader. It is pleasant indeed around this fire or at this +;; cafe or in this room, is it not? I think so too. +;; +;; This macro used to generate code that looked like this: +;; +;; `(((record-predicate ,record-type) ,r) +;; (let ,(map (lambda (slot) +;; (if (pair? slot) +;; `(,(car slot) ((record-accessor ,record-type ',(cadr slot)) ,r)) +;; `(,slot ((record-accessor ,record-type ',slot) ,r)))) +;; slots) +;; ,@body))))) +;; +;; But this was a hot spot, so computing all those predicates and +;; accessors all the time was getting expensive, so we did a terrible +;; thing: we decided that since above we're already defining accessors +;; and predicates with computed names, we might as well just rely on that fact here. +;; +;; It's a bit nasty, I agree. But it is fast. +;; +;;scheme@(guile-user)> (with-statprof #:hz 1000 #:full-stacks? #t (resolve-module '(oop goops)))% cumulative self +;; time seconds seconds name +;; 8.82 0.03 0.01 glil->assembly +;; 8.82 0.01 0.01 record-type-fields +;; 5.88 0.01 0.01 %compute-initargs +;; 5.88 0.01 0.01 list-index + + +;;; So ugly... but I am too ignorant to know how to make it better. +(define-syntax record-case + (lambda (x) + (syntax-case x () + ((_ record clause ...) + (let ((r (syntax r)) + (rtd (syntax rtd))) + (define (process-clause tag fields exprs) + (let ((infix (trim-brackets (syntax->datum tag)))) + (with-syntax ((tag tag) + (((f . accessor) ...) + (let lp ((fields fields)) + (syntax-case fields () + (() (syntax ())) + (((v0 f0) f1 ...) + (acons (syntax v0) + (datum->syntax x + (symbol-append infix '- (syntax->datum + (syntax f0)))) + (lp (syntax (f1 ...))))) + ((f0 f1 ...) + (acons (syntax f0) + (datum->syntax x + (symbol-append infix '- (syntax->datum + (syntax f0)))) + (lp (syntax (f1 ...)))))))) + ((e0 e1 ...) + (syntax-case exprs () + (() (syntax (#t))) + ((e0 e1 ...) (syntax (e0 e1 ...)))))) + (syntax + ((eq? rtd tag) + (let ((f (accessor r)) + ...) + e0 e1 ...)))))) + (with-syntax + ((r r) + (rtd rtd) + ((processed ...) + (let lp ((clauses (syntax (clause ...))) + (out '())) + (syntax-case clauses (else) + (() + (reverse! (cons (syntax + (else (error "unhandled record" r))) + out))) + (((else e0 e1 ...)) + (reverse! (cons (syntax (else e0 e1 ...)) out))) + (((else e0 e1 ...) . rest) + (syntax-violation 'record-case + "bad else clause placement" + (syntax x) + (syntax (else e0 e1 ...)))) + ((((<foo> f0 ...) e0 ...) . rest) + (lp (syntax rest) + (cons (process-clause (syntax <foo>) + (syntax (f0 ...)) + (syntax (e0 ...))) + out))))))) + (syntax + (let* ((r record) + (rtd (struct-vtable r))) + (cond processed ...))))))))) + + +;; Here we take the terrorism to another level. Nasty, but the client +;; code looks good. + +(define-macro (transform-record type-and-common record . clauses) + (let ((r (gensym)) + (rtd (gensym)) + (type-stem (trim-brackets (car type-and-common)))) + (define (make-stem s) + (symbol-append type-stem '- s)) + (define (further-predicates x record-stem slots) + (define (access slot) + `(,(symbol-append (make-stem record-stem) '- slot) ,x)) + (let lp ((in slots) (out '())) + (cond ((null? in) out) + ((pair? (car in)) + (let ((slot (caar in)) + (arg (cadar in))) + (cond ((symbol? arg) + (lp (cdr in) out)) + ((pair? arg) + (lp (cdr in) + (append (further-predicates (access slot) + (car arg) + (cdr arg)) + out))) + (else (lp (cdr in) (cons `(eq? ,(access slot) ',arg) + out)))))) + (else (lp (cdr in) out))))) + (define (let-clauses x record-stem slots) + (define (access slot) + `(,(symbol-append (make-stem record-stem) '- slot) ,x)) + (let lp ((in slots) (out '())) + (cond ((null? in) out) + ((pair? (car in)) + (let ((slot (caar in)) + (arg (cadar in))) + (cond ((symbol? arg) + (lp (cdr in) + (cons `(,arg ,(access slot)) out))) + ((pair? arg) + (lp (cdr in) + (append (let-clauses (access slot) + (car arg) + (cdr arg)) + out))) + (else + (lp (cdr in) out))))) + (else + (lp (cdr in) + (cons `(,(car in) ,(access (car in))) out)))))) + (define (transform-expr x) + (cond ((not (pair? x)) x) + ((eq? (car x) '->) + (if (= (length x) 2) + (let ((form (cadr x))) + `(,(symbol-append 'make- (make-stem (car form))) + ,@(cdr type-and-common) + ,@(map (lambda (y) + (if (and (pair? y) (eq? (car y) 'unquote)) + (transform-expr (cadr y)) + y)) + (cdr form)))) + (error "bad -> form" x))) + (else (cons (car x) (map transform-expr (cdr x)))))) + (define (process-clause clause) + (if (eq? (car clause) 'else) + clause + (let ((stem (caar clause)) + (slots (cdar clause)) + (body (cdr clause))) + (let ((record-type (symbol-append '< (make-stem stem) '>))) + `((and (eq? ,rtd ,record-type) + ,@(reverse (further-predicates r stem slots))) + (let ,(reverse (let-clauses r stem slots)) + ,@(if (pair? body) + (map transform-expr body) + '((if #f #f))))))))) + `(let* ((,r ,record) + (,rtd (struct-vtable ,r)) + ,@(map (lambda (slot) + `(,slot (,(make-stem slot) ,r))) + (cdr type-and-common))) + (cond ,@(let ((clauses (map process-clause clauses))) + (if (assq 'else clauses) + clauses + (append clauses `((else (error "unhandled record" ,r)))))))))) diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm new file mode 100644 index 000000000..a99e1bae9 --- /dev/null +++ b/module/system/repl/command.scm @@ -0,0 +1,502 @@ +;;; Repl commands + +;; Copyright (C) 2001, 2009 Free Software Foundation, Inc. + +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 3 of the License, or (at your option) any later version. +;; +;; This library 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 +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +;; 02110-1301 USA + +;;; Code: + +(define-module (system repl command) + #:use-module (system base syntax) + #:use-module (system base pmatch) + #:use-module (system base compile) + #:use-module (system repl common) + #:use-module (system vm objcode) + #:use-module (system vm program) + #:use-module (system vm vm) + #:autoload (system base language) (lookup-language language-reader) + #: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) + #:use-module (ice-9 rdelim) + #: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)) + +;; Hack, until core can be extended. +(define procedure-documentation + (let ((old-definition procedure-documentation)) + (lambda (p) + (if (program? p) + (program-documentation p) + (old-definition p))))) + +(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 (read-datum repl) + (read)) + +(define read-line + (let ((orig-read-line read-line)) + (lambda (repl) + (orig-read-line)))) + +(define (meta-command repl) + (let ((command (read-datum repl))) + (if (not (symbol? command)) + (user-error "Meta-command not a symbol: ~s" command)) + (let ((c (lookup-command command))) + (if c + ((command-procedure c) repl) + (user-error "Unknown meta command: ~A" command))))) + +(define-syntax define-meta-command + (syntax-rules () + ((_ (name repl (expression0 ...) . datums) docstring b0 b1 ...) + (define (name repl) + docstring + (let* ((expression0 + (with-fluid* current-reader + (language-reader (repl-language repl)) + (lambda () (repl-reader "")))) + ...) + (apply (lambda datums b0 b1 ...) + (let ((port (open-input-string (read-line repl)))) + (let lp ((out '())) + (let ((x (read port))) + (if (eof-object? x) + (reverse out) + (lp (cons x out)))))))))) + ((_ (name repl . datums) docstring b0 b1 ...) + (define-meta-command (name repl () . datums) + docstring b0 b1 ...)))) + + + +;;; +;;; Help commands +;;; + +(define-meta-command (help repl . args) + "help +help GROUP +help [-c] COMMAND + +Gives help on the meta-commands available at the REPL. + +With one argument, tries to look up the argument as a group name, giving +help on that group if successful. Otherwise tries to look up the +argument as a command, giving help on the command. + +If there is a command whose name is also a group name, use the ,help +-c COMMAND form to give help on the command instead of the group. + +Without any argument, a list of help commands and command groups +are displayed." + (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))) + ((,command) (guard (lookup-command command)) + (display-command (lookup-command command))) + ((-c ,command) (guard (lookup-command command)) + (display-command (lookup-command command))) + ((,command) + (user-error "Unknown command or group: ~A" command)) + ((-c ,command) + (user-error "Unknown command: ~A" command)) + (else + (user-error "Bad arguments: ~A" args)))) + +(define guile:apropos apropos) +(define-meta-command (apropos repl regexp) + "apropos REGEXP +Find bindings/modules/packages." + (guile:apropos (->string regexp))) + +(define-meta-command (describe repl (form)) + "describe OBJ +Show description/documentation." + (display (object-documentation (repl-eval repl (repl-parse repl form)))) + (newline)) + +(define-meta-command (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-meta-command (quit repl) + "quit +Quit this session." + (throw 'quit)) + + +;;; +;;; Module commands +;;; + +(define-meta-command (module repl . args) + "module [MODULE] +Change modules / Show current module." + (pmatch args + (() (puts (module-name (current-module)))) + ((,mod-name) (guard (list? mod-name)) + (set-current-module (resolve-module mod-name))) + (,mod-name (set-current-module (resolve-module mod-name))))) + +(define-meta-command (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-meta-command (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-meta-command (binding repl) + "binding +List current bindings." + (module-for-each (lambda (k v) (format #t "~23A ~A\n" k v)) + (current-module))) + + +;;; +;;; Language commands +;;; + +(define-meta-command (language repl name) + "language LANGUAGE +Change languages." + (set! (repl-language repl) (lookup-language name)) + (repl-welcome repl)) + + +;;; +;;; Compile commands +;;; + +(define-meta-command (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 (repl-parse repl form) opts))) + (cond ((objcode? x) (guile:disassemble x)) + (else (repl-print repl x))))) + +(define guile:compile-file compile-file) +(define-meta-command (compile-file repl file . opts) + "compile-file FILE +Compile a file." + (guile:compile-file (->string file) #:opts opts)) + +(define (guile:disassemble x) + ((@ (language assembly disassemble) disassemble) x)) + +(define-meta-command (disassemble repl (form)) + "disassemble PROGRAM +Disassemble a program." + (guile:disassemble (repl-eval repl (repl-parse repl form)))) + +(define-meta-command (disassemble-file repl file) + "disassemble-file FILE +Disassemble a file." + (guile:disassemble (load-objcode (->string file)))) + + +;;; +;;; Profile commands +;;; + +(define-meta-command (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 (repl-parse repl form))) + (tms-end (times)) + (gc-end (gc-run-time)) + (vms-end (vm-stats (repl-vm repl)))) + (define (get proc start end) + (exact->inexact (/ (- (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-meta-command (profile repl form . opts) + "profile FORM +Profile execution." + (apply vm-profile + (repl-vm repl) + (repl-compile repl (repl-parse repl form)) + opts)) + + +;;; +;;; Debug commands +;;; + +(define-meta-command (backtrace repl) + "backtrace +Display backtrace." + (vm-backtrace (repl-vm repl))) + +(define-meta-command (debugger repl) + "debugger +Start debugger." + (vm-debugger (repl-vm repl))) + +(define-meta-command (trace repl form . opts) + "trace FORM +Trace execution. + + -s Display stack + -l Display local variables + -b Bytecode level trace" + (apply vm-trace (repl-vm repl) + (repl-compile repl (repl-parse repl form)) + opts)) + +(define-meta-command (step repl) + "step FORM +Step execution." + (display "Not implemented yet\n")) + + +;;; +;;; System commands +;;; + +(define guile:gc gc) +(define-meta-command (gc repl) + "gc +Garbage collection." + (guile:gc)) + +(define-meta-command (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-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 "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" (exact->inexact (/ 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.0)))) + (display-stat title #f + (mips (- this-time last-time) (- this-clock last-clock)) + (mips this-time this-clock) "mips")) diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm new file mode 100644 index 000000000..2db4518ad --- /dev/null +++ b/module/system/repl/common.scm @@ -0,0 +1,112 @@ +;;; Repl common routines + +;; Copyright (C) 2001 Free Software Foundation, Inc. + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public +;;; License as published by the Free Software Foundation; either +;;; version 3 of the License, or (at your option) any later version. +;;; +;;; This library 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 +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (system repl common) + #:use-module (system base syntax) + #:use-module (system base compile) + #:use-module (system base language) + #:use-module (system vm vm) + #:export (<repl> make-repl repl-vm repl-language repl-options + repl-tm-stats repl-gc-stats repl-vm-stats + repl-welcome repl-prompt repl-read repl-compile repl-eval + repl-parse repl-print repl-option-ref repl-option-set! + puts ->string user-error)) + + +;;; +;;; Repl type +;;; + +(define-record/keywords <repl> vm language options tm-stats gc-stats vm-stats) + +(define repl-default-options + '((trace . #f) + (interp . #f))) + +(define %make-repl make-repl) +(define (make-repl lang) + (%make-repl #:vm (the-vm) + #:language (lookup-language lang) + #:options repl-default-options + #:tm-stats (times) + #:gc-stats (gc-stats) + #:vm-stats (vm-stats (the-vm)))) + +(define (repl-welcome repl) + (let ((language (repl-language repl))) + (format #t "~A interpreter ~A on Guile ~A\n" + (language-title language) (language-version language) (version))) + (display "Copyright (C) 2001-2008 Free Software Foundation, Inc.\n\n") + (display "Enter `,help' for help.\n")) + +(define (repl-prompt repl) + (format #f "~A@~A> " (language-name (repl-language repl)) + (module-name (current-module)))) + +(define (repl-read repl) + ((language-reader (repl-language repl)))) + +(define (repl-compile repl form . opts) + (let ((to (lookup-language (cond ((memq #:e opts) 'scheme) + ((memq #:t opts) 'ghil) + ((memq #:c opts) 'glil) + (else 'objcode))))) + (compile form #:from (repl-language repl) #:to to #:opts opts))) + +(define (repl-parse repl form) + (let ((parser (language-parser (repl-language repl)))) + (if parser (parser form) form))) + +(define (repl-eval repl form) + (let ((eval (language-evaluator (repl-language repl)))) + (if (and eval + (or (null? (language-compilers (repl-language repl))) + (assq-ref (repl-options repl) 'interp))) + (eval form (current-module)) + (vm-load (repl-vm repl) (repl-compile repl form '()))))) + +(define (repl-print repl val) + (if (not (eq? val *unspecified*)) + (begin + ;; The result of an evaluation is representable in scheme, and + ;; should be printed with the generic printer, `write'. The + ;; language-printer is something else: it prints expressions of + ;; a given language, not the result of evaluation. + (write val) + (newline)))) + +(define (repl-option-ref repl key) + (assq-ref (repl-options repl) key)) + +(define (repl-option-set! repl key val) + (set! (repl-options repl) (assq-set! (repl-options repl) key val))) + + +;;; +;;; Utilities +;;; + +(define (puts x) (display x) (newline)) + +(define (->string x) + (object->string x display)) + +(define (user-error msg . args) + (throw 'user-error #f msg args #f)) diff --git a/module/system/repl/describe.scm b/module/system/repl/describe.scm new file mode 100644 index 000000000..590d2235a --- /dev/null +++ b/module/system/repl/describe.scm @@ -0,0 +1,360 @@ +;;; Describe objects + +;; Copyright (C) 2001 Free Software Foundation, Inc. + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public +;;; License as published by the Free Software Foundation; either +;;; version 3 of the License, or (at your option) any later version. +;;; +;;; This library 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 +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (system repl describe) + #:use-module (oop goops) + #:use-module (ice-9 regex) + #:use-module (ice-9 format) + #:use-module (ice-9 and-let-star) + #:export (describe)) + +(define-method (describe (symbol <symbol>)) + (format #t "`~s' is " symbol) + (if (not (defined? symbol)) + (display "not defined in the current module.\n") + (describe-object (module-ref (current-module) symbol)))) + + +;;; +;;; Display functions +;;; + +(define (safe-class-name class) + (if (slot-bound? class 'name) + (class-name class) + class)) + +(define-method (display-class class . args) + (let* ((name (safe-class-name class)) + (desc (if (pair? args) (car args) name))) + (if (eq? *describe-format* 'tag) + (format #t "@class{~a}{~a}" name desc) + (format #t "~a" desc)))) + +(define (display-list title list) + (if title (begin (display title) (display ":\n\n"))) + (if (null? list) + (display "(not defined)\n") + (for-each display-summary list))) + +(define (display-slot-list title instance list) + (if title (begin (display title) (display ":\n\n"))) + (if (null? list) + (display "(not defined)\n") + (for-each (lambda (slot) + (let ((name (slot-definition-name slot))) + (display "Slot: ") + (display name) + (if (and instance (slot-bound? instance name)) + (begin + (display " = ") + (display (slot-ref instance name)))) + (newline))) + list))) + +(define (display-file location) + (display "Defined in ") + (if (eq? *describe-format* 'tag) + (format #t "@location{~a}.\n" location) + (format #t "`~a'.\n" location))) + +(define (format-documentation doc) + (with-current-buffer (make-buffer #:text doc) + (lambda () + (let ((regexp (make-regexp "@([a-z]*)(\\{([^}]*)\\})?"))) + (do-while (match (re-search-forward regexp)) + (let ((key (string->symbol (match:substring match 1))) + (value (match:substring match 3))) + (case key + ((deffnx) + (delete-region! (match:start match) + (begin (forward-line) (point)))) + ((var) + (replace-match! match 0 (string-upcase value))) + ((code) + (replace-match! match 0 (string-append "`" value "'"))))))) + (display (string (current-buffer))) + (newline)))) + + +;;; +;;; Top +;;; + +(define description-table + (list + (cons <boolean> "a boolean") + (cons <null> "an empty list") + (cons <integer> "an integer") + (cons <real> "a real number") + (cons <complex> "a complex number") + (cons <char> "a character") + (cons <symbol> "a symbol") + (cons <keyword> "a keyword") + (cons <promise> "a promise") + (cons <hook> "a hook") + (cons <fluid> "a fluid") + (cons <stack> "a stack") + (cons <variable> "a variable") + (cons <regexp> "a regexp object") + (cons <module> "a module object") + (cons <unknown> "an unknown object"))) + +(define-generic describe-object) +(export describe-object) + +(define-method (describe-object (obj <top>)) + (display-type obj) + (display-location obj) + (newline) + (display-value obj) + (newline) + (display-documentation obj)) + +(define-generic display-object) +(define-generic display-summary) +(define-generic display-type) +(define-generic display-value) +(define-generic display-location) +(define-generic display-description) +(define-generic display-documentation) +(export display-object display-summary display-type display-value + display-location display-description display-documentation) + +(define-method (display-object (obj <top>)) + (write obj)) + +(define-method (display-summary (obj <top>)) + (display "Value: ") + (display-object obj) + (newline)) + +(define-method (display-type (obj <top>)) + (cond + ((eof-object? obj) (display "the end-of-file object")) + ((unspecified? obj) (display "unspecified")) + (else (let ((class (class-of obj))) + (display-class class (or (assq-ref description-table class) + (safe-class-name class)))))) + (display ".\n")) + +(define-method (display-value (obj <top>)) + (if (not (unspecified? obj)) + (begin (display-object obj) (newline)))) + +(define-method (display-location (obj <top>)) + *unspecified*) + +(define-method (display-description (obj <top>)) + (let* ((doc (with-output-to-string (lambda () (display-documentation obj)))) + (index (string-index doc #\newline))) + (display (make-shared-substring doc 0 (1+ index))))) + +(define-method (display-documentation (obj <top>)) + (display "Not documented.\n")) + + +;;; +;;; Pairs +;;; + +(define-method (display-type (obj <pair>)) + (cond + ((list? obj) (display-class <list> "a list")) + ((pair? (cdr obj)) (display "an improper list")) + (else (display-class <pair> "a pair"))) + (display ".\n")) + + +;;; +;;; Strings +;;; + +(define-method (display-type (obj <string>)) + (if (read-only-string? 'obj) + (display "a read-only string") + (display-class <string> "a string")) + (display ".\n")) + + +;;; +;;; Procedures +;;; + +(define-method (display-object (obj <procedure>)) + (cond + ((closure? obj) + ;; Construct output from the source. + (display "(") + (display (procedure-name obj)) + (let ((args (cadr (procedure-source obj)))) + (cond ((null? args) (display ")")) + ((pair? args) + (let ((str (with-output-to-string (lambda () (display args))))) + (format #t " ~a" (string-upcase! (substring str 1))))) + (else + (format #t " . ~a)" (string-upcase! (symbol->string args))))))) + (else + ;; Primitive procedure. Let's lookup the dictionary. + (and-let* ((entry (lookup-procedure obj))) + (let ((name (entry-property entry 'name)) + (print-arg (lambda (arg) + (display " ") + (display (string-upcase (symbol->string arg)))))) + (display "(") + (display name) + (and-let* ((args (entry-property entry 'args))) + (for-each print-arg args)) + (and-let* ((opts (entry-property entry 'opts))) + (display " &optional") + (for-each print-arg opts)) + (and-let* ((rest (entry-property entry 'rest))) + (display " &rest") + (print-arg rest)) + (display ")")))))) + +(define-method (display-summary (obj <procedure>)) + (display "Procedure: ") + (display-object obj) + (newline) + (display " ") + (display-description obj)) + +(define-method (display-type (obj <procedure>)) + (cond + ((and (thunk? obj) (not (procedure-name obj))) (display "a thunk")) + ((closure? obj) (display-class <procedure> "a procedure")) + ((procedure-with-setter? obj) + (display-class <procedure-with-setter> "a procedure with setter")) + ((not (struct? obj)) (display "a primitive procedure")) + (else (display-class <procedure> "a procedure"))) + (display ".\n")) + +(define-method (display-location (obj <procedure>)) + (and-let* ((entry (lookup-procedure obj))) + (display-file (entry-file entry)))) + +(define-method (display-documentation (obj <procedure>)) + (cond ((cond ((closure? obj) (procedure-documentation obj)) + ((lookup-procedure obj) => entry-text) + (else #f)) + => format-documentation) + (else (next-method)))) + + +;;; +;;; Classes +;;; + +(define-method (describe-object (obj <class>)) + (display-type obj) + (display-location obj) + (newline) + (display-documentation obj) + (newline) + (display-value obj)) + +(define-method (display-summary (obj <class>)) + (display "Class: ") + (display-class obj) + (newline) + (display " ") + (display-description obj)) + +(define-method (display-type (obj <class>)) + (display-class <class> "a class") + (if (not (eq? (class-of obj) <class>)) + (begin (display " of ") (display-class (class-of obj)))) + (display ".\n")) + +(define-method (display-value (obj <class>)) + (display-list "Class precedence list" (class-precedence-list obj)) + (newline) + (display-list "Direct superclasses" (class-direct-supers obj)) + (newline) + (display-list "Direct subclasses" (class-direct-subclasses obj)) + (newline) + (display-slot-list "Direct slots" #f (class-direct-slots obj)) + (newline) + (display-list "Direct methods" (class-direct-methods obj))) + + +;;; +;;; Instances +;;; + +(define-method (display-type (obj <object>)) + (display-class <object> "an instance") + (display " of class ") + (display-class (class-of obj)) + (display ".\n")) + +(define-method (display-value (obj <object>)) + (display-slot-list #f obj (class-slots (class-of obj)))) + + +;;; +;;; Generic functions +;;; + +(define-method (display-type (obj <generic>)) + (display-class <generic> "a generic function") + (display " of class ") + (display-class (class-of obj)) + (display ".\n")) + +(define-method (display-value (obj <generic>)) + (display-list #f (generic-function-methods obj))) + + +;;; +;;; Methods +;;; + +(define-method (display-object (obj <method>)) + (display "(") + (let ((gf (method-generic-function obj))) + (display (if gf (generic-function-name gf) "#<anonymous>"))) + (let loop ((args (method-specializers obj))) + (cond + ((null? args)) + ((pair? args) + (display " ") + (display-class (car args)) + (loop (cdr args))) + (else (display " . ") (display-class args)))) + (display ")")) + +(define-method (display-summary (obj <method>)) + (display "Method: ") + (display-object obj) + (newline) + (display " ") + (display-description obj)) + +(define-method (display-type (obj <method>)) + (display-class <method> "a method") + (display " of class ") + (display-class (class-of obj)) + (display ".\n")) + +(define-method (display-documentation (obj <method>)) + (let ((doc (procedure-documentation (method-procedure obj)))) + (if doc (format-documentation doc) (next-method)))) diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm new file mode 100644 index 000000000..2f4a3783a --- /dev/null +++ b/module/system/repl/repl.scm @@ -0,0 +1,150 @@ +;;; Read-Eval-Print Loop + +;; Copyright (C) 2001, 2009 Free Software Foundation, Inc. + +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 3 of the License, or (at your option) any later version. +;; +;; This library 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 +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +;; 02110-1301 USA + +;;; Code: + +(define-module (system repl repl) + #:use-module (system base syntax) + #:use-module (system base pmatch) + #:use-module (system base compile) + #:use-module (system base language) + #:use-module (system repl common) + #:use-module (system repl command) + #:use-module (system vm vm) + #:use-module (system vm debug) + #:export (start-repl call-with-backtrace)) + +(define meta-command-token (cons 'meta 'command)) + +(define (meta-reader read) + (lambda read-args + (with-input-from-port + (if (pair? read-args) (car read-args) (current-input-port)) + (lambda () + (let ((ch (next-char #t))) + (cond ((eof-object? ch) + ;; apparently sometimes even if this is eof, read will + ;; wait on somethingorother. strange. + ch) + ((eqv? ch #\,) + (read-char) + meta-command-token) + (else (read)))))))) + +;; repl-reader is a function defined in boot-9.scm, and is replaced by +;; something else if readline has been activated. much of this hoopla is +;; to be able to re-use the existing readline machinery. +(define (prompting-meta-read repl) + (let ((prompt (lambda () (repl-prompt repl))) + (lread (language-reader (repl-language repl)))) + (with-fluid* current-reader (meta-reader lread) + (lambda () (repl-reader (lambda () (repl-prompt repl))))))) + +(define (default-catch-handler . args) + (pmatch args + ((quit . _) + (apply throw args)) + ((,key ,subr ,msg ,args . ,rest) + (let ((cep (current-error-port))) + (cond ((not (stack? (fluid-ref the-last-stack)))) + ((memq 'backtrace (debug-options-interface)) + (let ((highlights (if (or (eq? key 'wrong-type-arg) + (eq? key 'out-of-range)) + (car rest) + '()))) + (run-hook before-backtrace-hook) + (newline cep) + (display "Backtrace:\n") + (display-backtrace (fluid-ref the-last-stack) cep + #f #f highlights) + (newline cep) + (run-hook after-backtrace-hook)))) + (run-hook before-error-hook) + (display-error (fluid-ref the-last-stack) cep subr msg args rest) + (run-hook after-error-hook) + (set! stack-saved? #f) + (force-output cep))) + (else + (format (current-error-port) "\nERROR: uncaught throw to `~a', args: ~a\n" + (car args) (cdr args))))) + +(define (call-with-backtrace thunk) + (catch #t + (lambda () (%start-stack #t thunk)) + default-catch-handler + default-pre-unwind-handler)) + +(define-macro (with-backtrace form) + `(call-with-backtrace (lambda () ,form))) + +(define (start-repl lang) + (let ((repl (make-repl lang)) + (status #f)) + (repl-welcome repl) + (let prompt-loop () + (let ((exp (with-backtrace (prompting-meta-read repl)))) + (cond + ((eqv? exp (if #f #f))) ; read error, pass + ((eq? exp meta-command-token) + (with-backtrace (meta-command repl))) + ((eof-object? exp) + (newline) + (set! status '())) + (else + ;; since the input port is line-buffered, consume up to the + ;; newline + (flush-to-newline) + (with-backtrace + (catch 'quit + (lambda () + (call-with-values + (lambda () + (run-hook before-eval-hook exp) + (start-stack #t + (repl-eval repl (repl-parse repl exp)))) + (lambda l + (for-each (lambda (v) + (run-hook before-print-hook v) + (repl-print repl v)) + l)))) + (lambda (k . args) + (set! status args)))))) + (or status + (begin + (next-char #f) ;; consume trailing whitespace + (prompt-loop))))))) + +(define (next-char wait) + (if (or wait (char-ready?)) + (let ((ch (peek-char))) + (cond ((eof-object? ch) ch) + ((char-whitespace? ch) (read-char) (next-char wait)) + (else ch))) + #f)) + +(define (flush-to-newline) + (if (char-ready?) + (let ((ch (peek-char))) + (if (and (not (eof-object? ch)) (char-whitespace? ch)) + (begin + (read-char) + (if (not (char=? ch #\newline)) + (flush-to-newline))))))) + +
\ No newline at end of file diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm new file mode 100644 index 000000000..740111257 --- /dev/null +++ b/module/system/vm/debug.scm @@ -0,0 +1,62 @@ +;;; Guile VM debugging facilities + +;; 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 vm debug) + #:use-module (system base syntax) + #:use-module (system vm vm) + #:use-module (system vm frame) + #:use-module (ice-9 format) + #:export (vm-debugger vm-backtrace)) + + +;;; +;;; Debugger +;;; + +(define-record/keywords <debugger> vm chain index) + +(define (vm-debugger vm) + (let ((chain (vm-last-frame-chain vm))) + (if (null? chain) + (display "Nothing to debug\n") + (debugger-repl (make-debugger + #:vm vm #:chain chain #:index (length chain)))))) + +(define (debugger-repl db) + (let loop () + (display "debug> ") + (let ((cmd (read))) + (case cmd + ((bt) (vm-backtrace (debugger-vm db))) + ((stack) + (write (vm-fetch-stack (debugger-vm db))) + (newline)) + (else + (format #t "Unknown command: ~A" cmd)))))) + + +;;; +;;; Backtrace +;;; + +(define (vm-backtrace vm) + (print-frame-chain-as-backtrace + (reverse (vm-last-frame-chain vm)))) diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm new file mode 100644 index 000000000..332cd6172 --- /dev/null +++ b/module/system/vm/frame.scm @@ -0,0 +1,209 @@ +;;; Guile VM frame functions + +;;; Copyright (C) 2001, 2009 Free Software Foundation, Inc. +;;; Copyright (C) 2005 Ludovic Courtès <ludovic.courtes@laas.fr> +;;; +;;; 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 of the License, 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; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (system vm frame) + #:use-module (system vm program) + #:use-module (system vm instruction) + #:use-module ((srfi srfi-1) #:select (fold)) + #:export (vm-frame? + vm-frame-program + vm-frame-local-ref vm-frame-local-set! + vm-frame-return-address vm-frame-mv-return-address + vm-frame-dynamic-link + vm-frame-stack + + + vm-frame-number vm-frame-address + make-frame-chain + print-frame print-frame-chain-as-backtrace + frame-arguments frame-local-variables + frame-environment + frame-variable-exists? frame-variable-ref frame-variable-set! + frame-object-name + frame-local-ref frame-local-set! + frame-return-address frame-program + frame-dynamic-link heap-frame?)) + +(load-extension "libguile" "scm_init_frames") + +;;; +;;; Frame chain +;;; + +(define vm-frame-number (make-object-property)) +(define vm-frame-address (make-object-property)) + +;; FIXME: the header. +(define (bootstrap-frame? frame) + (let ((code (objcode->bytecode (program-objcode (frame-program frame))))) + (and (= (uniform-vector-ref code (1- (uniform-vector-length code))) + (instruction->opcode 'halt))))) + +(define (make-frame-chain frame addr) + (define (make-rest) + (make-frame-chain (frame-dynamic-link frame) + (frame-return-address frame))) + (cond + ((or (eq? frame #t) (eq? frame #f)) + ;; handle #f or #t dynamic links + '()) + ((bootstrap-frame? frame) + (make-rest)) + (else + (let ((chain (make-rest))) + (set! (frame-number frame) (length chain)) + (set! (frame-address frame) + (- addr (program-base (frame-program frame)))) + (cons frame chain))))) + + +;;; +;;; Pretty printing +;;; + +(define (frame-line-number frame) + (let ((addr (frame-address frame))) + (cond ((assv addr (program-sources (frame-program frame))) + => source:line) + (else (format #f "@~a" addr))))) + +(define (frame-file frame prev) + (let ((sources (program-sources (frame-program frame)))) + (if (null? sources) + prev + (or (source:file (car sources)) + "current input")))) + +(define (print-frame frame) + (format #t "~4@a: ~a ~s\n" (frame-line-number frame) (frame-number frame) + (frame-call-representation frame))) + + +(define (frame-call-representation frame) + (define (abbrev x) + (cond ((list? x) + (if (> (length x) 4) + (list (abbrev (car x)) (abbrev (cadr x)) '...) + (map abbrev x))) + ((pair? x) + (cons (abbrev (car x)) (abbrev (cdr x)))) + ((vector? x) + (case (vector-length x) + ((0) x) + ((1) (vector (abbrev (vector-ref x 0)))) + (else (vector (abbrev (vector-ref x 0)) '...)))) + (else x))) + (abbrev (cons (frame-program-name frame) (frame-arguments frame)))) + +(define (print-frame-chain-as-backtrace frames) + (if (null? frames) + (format #t "No backtrace available.\n") + (begin + (format #t "VM backtrace:\n") + (fold (lambda (frame file) + (let ((new-file (frame-file frame file))) + (if (not (equal? new-file file)) + (format #t "In ~a:\n" new-file)) + (print-frame frame) + new-file)) + 'no-file + frames)))) + +(define (frame-program-name frame) + (let ((prog (frame-program frame)) + (link (frame-dynamic-link frame))) + (or (program-name prog) + (object-property prog 'name) + (and (heap-frame? link) (frame-address link) + (frame-object-name link (1- (frame-address link)) prog)) + (hash-fold (lambda (s v d) (if (and (variable-bound? v) + (eq? prog (variable-ref v))) + s d)) + prog (module-obarray (current-module)))))) + + +;;; +;;; Frames +;;; + +(define (frame-arguments frame) + (let* ((prog (frame-program frame)) + (arity (program-arity prog))) + (do ((n (+ (arity:nargs arity) -1) (1- n)) + (l '() (cons (frame-local-ref frame n) l))) + ((< n 0) l)))) + +(define (frame-local-variables frame) + (let* ((prog (frame-program frame)) + (arity (program-arity prog))) + (do ((n (+ (arity:nargs arity) (arity:nlocs arity) -1) (1- n)) + (l '() (cons (frame-local-ref frame n) l))) + ((< n 0) l)))) + +(define (frame-binding-ref frame binding) + (let ((x (frame-local-ref frame (binding:index binding)))) + (if (and (binding:boxed? binding) (variable? x)) + (variable-ref x) + x))) + +(define (frame-binding-set! frame binding val) + (if (binding:boxed? binding) + (let ((v (frame-local-ref frame binding))) + (if (variable? v) + (variable-set! v val) + (frame-local-set! frame binding (make-variable val)))) + (frame-local-set! frame binding val))) + +;; FIXME handle #f program-bindings return +(define (frame-bindings frame addr) + (filter (lambda (b) (and (>= addr (binding:start b)) + (<= addr (binding:end b)))) + (program-bindings (frame-program frame)))) + +(define (frame-lookup-binding frame addr sym) + (assq sym (reverse (frame-bindings frame addr)))) + +(define (frame-object-binding frame addr obj) + (do ((bs (frame-bindings frame addr) (cdr bs))) + ((or (null? bs) (eq? obj (frame-binding-ref frame (car bs)))) + (and (pair? bs) (car bs))))) + +(define (frame-environment frame addr) + (map (lambda (binding) + (cons (binding:name binding) (frame-binding-ref frame binding))) + (frame-bindings frame addr))) + +(define (frame-variable-exists? frame addr sym) + (if (frame-lookup-binding frame addr sym) #t #f)) + +(define (frame-variable-ref frame addr sym) + (cond ((frame-lookup-binding frame addr sym) => + (lambda (binding) (frame-binding-ref frame binding))) + (else (error "Unknown variable:" sym)))) + +(define (frame-variable-set! frame addr sym val) + (cond ((frame-lookup-binding frame addr sym) => + (lambda (binding) (frame-binding-set! frame binding val))) + (else (error "Unknown variable:" sym)))) + +(define (frame-object-name frame addr obj) + (cond ((frame-object-binding frame addr obj) => binding:name) + (else #f))) diff --git a/module/system/vm/instruction.scm b/module/system/vm/instruction.scm new file mode 100644 index 000000000..403e9cdc7 --- /dev/null +++ b/module/system/vm/instruction.scm @@ -0,0 +1,27 @@ +;;; Guile VM instructions + +;; Copyright (C) 2001 Free Software Foundation, Inc. + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public +;;; License as published by the Free Software Foundation; either +;;; version 3 of the License, or (at your option) any later version. +;;; +;;; This library 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 +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (system vm instruction) + #:export (instruction-list + instruction? instruction-length + instruction-pops instruction-pushes + instruction->opcode opcode->instruction)) + +(load-extension "libguile" "scm_init_instructions") diff --git a/module/system/vm/objcode.scm b/module/system/vm/objcode.scm new file mode 100644 index 000000000..7c0490da6 --- /dev/null +++ b/module/system/vm/objcode.scm @@ -0,0 +1,27 @@ +;;; Guile VM object code + +;; Copyright (C) 2001 Free Software Foundation, Inc. + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public +;;; License as published by the Free Software Foundation; either +;;; version 3 of the License, or (at your option) any later version. +;;; +;;; This library 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 +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (system vm objcode) + #:export (objcode? objcode-meta + bytecode->objcode objcode->bytecode + load-objcode write-objcode + word-size byte-order)) + +(load-extension "libguile" "scm_init_objcodes") diff --git a/module/system/vm/profile.scm b/module/system/vm/profile.scm new file mode 100644 index 000000000..6ab418ac3 --- /dev/null +++ b/module/system/vm/profile.scm @@ -0,0 +1,64 @@ +;;; Guile VM profiler + +;; Copyright (C) 2001 Free Software Foundation, Inc. + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public +;;; License as published by the Free Software Foundation; either +;;; version 3 of the License, or (at your option) any later version. +;;; +;;; This library 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 +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (system vm profile) + #:use-module (system vm vm) + #:use-module (ice-9 format) + #:export (vm-profile)) + +(define (vm-profile vm objcode . opts) + (let ((flag (vm-option vm 'debug))) + (dynamic-wind + (lambda () + (set-vm-option! vm 'debug #t) + (set-vm-option! vm 'profile-data '()) + (add-hook! (vm-next-hook vm) profile-next) + (add-hook! (vm-enter-hook vm) profile-enter) + (add-hook! (vm-exit-hook vm) profile-exit)) + (lambda () + (vm-load vm objcode) + (print-result vm)) + (lambda () + (set-vm-option! vm 'debug flag) + (remove-hook! (vm-next-hook vm) profile-next) + (remove-hook! (vm-enter-hook vm) profile-enter) + (remove-hook! (vm-exit-hook vm) profile-exit))))) + +(define (profile-next vm) + (set-vm-option! vm 'profile-data + (cons (vm-fetch-code vm) (vm-option vm 'profile-data)))) + +(define (profile-enter vm) + #f) + +(define (profile-exit vm) + #f) + +(define (print-result vm . opts) + (do ((data (vm-option vm 'profile-data) (cdr data)) + (summary '() (let ((inst (caar data))) + (assq-set! summary inst + (1+ (or (assq-ref summary inst) 0)))))) + ((null? data) + (display "Count Instruction\n") + (display "----- -----------\n") + (for-each (lambda (entry) + (format #t "~5@A ~A\n" (cdr entry) (car entry))) + (sort summary (lambda (e1 e2) (> (cdr e1) (cdr e2)))))))) diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm new file mode 100644 index 000000000..755c606e2 --- /dev/null +++ b/module/system/vm/program.scm @@ -0,0 +1,100 @@ +;;; Guile VM program functions + +;;; Copyright (C) 2001, 2009 Free Software Foundation, Inc. +;;; +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public +;;; License as published by the Free Software Foundation; either +;;; version 3 of the License, or (at your option) any later version. +;;; +;;; This library 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 +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (system vm program) + #:export (make-program + + arity:nargs arity:nrest arity:nlocs + + make-binding binding:name binding:boxed? binding:index + binding:start binding:end + + source:addr source:line source:column source:file + program-bindings program-sources program-source + program-properties program-property program-documentation + program-name program-arguments + + program-arity program-meta + program-objcode program? program-objects + program-module program-base program-free-variables)) + +(load-extension "libguile" "scm_init_programs") + +(define arity:nargs car) +(define arity:nrest cadr) +(define arity:nlocs caddr) + +(define (make-binding name boxed? index start end) + (list name boxed? index start end)) +(define (binding:name b) (list-ref b 0)) +(define (binding:boxed? b) (list-ref b 1)) +(define (binding:index b) (list-ref b 2)) +(define (binding:start b) (list-ref b 3)) +(define (binding:end b) (list-ref b 4)) + +(define (source:addr source) + (car source)) +(define (source:file source) + (cadr source)) +(define (source:line source) + (caddr source)) +(define (source:column source) + (cdddr source)) + +(define (program-property prog prop) + (assq-ref (program-properties proc) prop)) + +(define (program-documentation prog) + (assq-ref (program-properties prog) 'documentation)) + +(define (program-arguments prog) + (let ((bindings (program-bindings prog)) + (nargs (arity:nargs (program-arity prog))) + (rest? (not (zero? (arity:nrest (program-arity prog)))))) + (if bindings + (let ((args (map binding:name (list-head bindings nargs)))) + (if rest? + `((required . ,(list-head args (1- (length args)))) + (rest . ,(car (last-pair args)))) + `((required . ,args)))) + #f))) + +(define (program-bindings-as-lambda-list prog) + (let ((bindings (program-bindings prog)) + (nargs (arity:nargs (program-arity prog))) + (rest? (not (zero? (arity:nrest (program-arity prog)))))) + (if (not bindings) + (if rest? (cons (1- nargs) 1) (list nargs)) + (let ((args (map binding:name (list-head bindings nargs)))) + (if rest? + (apply cons* args) + args))))) + +(define (write-program prog port) + (format port "#<program ~a ~a>" + (or (program-name prog) + (and=> (program-source prog 0) + (lambda (s) + (format #f "~a at ~a:~a:~a" + (number->string (object-address prog) 16) + (or (source:file s) "<unknown port>") + (source:line s) (source:column s)))) + (number->string (object-address prog) 16)) + (program-bindings-as-lambda-list prog))) diff --git a/module/system/vm/trace.scm b/module/system/vm/trace.scm new file mode 100644 index 000000000..d8165f202 --- /dev/null +++ b/module/system/vm/trace.scm @@ -0,0 +1,76 @@ +;;; Guile VM tracer + +;; Copyright (C) 2001, 2009 Free Software Foundation, Inc. + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public +;;; License as published by the Free Software Foundation; either +;;; version 3 of the License, or (at your option) any later version. +;;; +;;; This library 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 +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (system vm trace) + #:use-module (system base syntax) + #:use-module (system vm vm) + #:use-module (system vm frame) + #:use-module (ice-9 format) + #:export (vm-trace vm-trace-on vm-trace-off)) + +(define (vm-trace vm objcode . opts) + (dynamic-wind + (lambda () (apply vm-trace-on vm opts)) + (lambda () (vm-load vm objcode)) + (lambda () (apply vm-trace-off vm opts)))) + +(define (vm-trace-on vm . opts) + (set-vm-option! vm 'trace-first #t) + (if (memq #:b opts) (add-hook! (vm-next-hook vm) trace-next)) + (set-vm-option! vm 'trace-options opts) + (add-hook! (vm-apply-hook vm) trace-apply) + (add-hook! (vm-return-hook vm) trace-return)) + +(define (vm-trace-off vm . opts) + (if (memq #:b opts) (remove-hook! (vm-next-hook vm) trace-next)) + (remove-hook! (vm-apply-hook vm) trace-apply) + (remove-hook! (vm-return-hook vm) trace-return)) + +(define (trace-next vm) + (define (puts x) (display #\tab) (write x)) + (define (truncate! x n) + (if (> (length x) n) + (list-cdr-set! x (1- n) '(...))) x) + ;; main + (format #t "0x~8X ~16S" (vm:ip vm) (vm-fetch-code vm)) + (do ((opts (vm-option vm 'trace-options) (cdr opts))) + ((null? opts) (newline)) + (case (car opts) + ((:s) (puts (truncate! (vm-fetch-stack vm) 3))) + ((:l) (puts (vm-fetch-locals vm)))))) + +(define (trace-apply vm) + (if (vm-option vm 'trace-first) + (set-vm-option! vm 'trace-first #f) + (let ((chain (vm-current-frame-chain vm))) + (print-indent chain) + (print-frame-call (car chain)) + (newline)))) + +(define (trace-return vm) + (let ((chain (vm-current-frame-chain vm))) + (print-indent chain) + (write (vm-return-value vm)) + (newline))) + +(define (print-indent chain) + (cond ((pair? (cdr chain)) + (display "| ") + (print-indent (cdr chain))))) diff --git a/module/system/vm/vm.scm b/module/system/vm/vm.scm new file mode 100644 index 000000000..48dc4f2b8 --- /dev/null +++ b/module/system/vm/vm.scm @@ -0,0 +1,41 @@ +;;; Guile VM core + +;; 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 vm vm) + #:use-module (system vm frame) + #:use-module (system vm program) + #:export (vm? the-vm make-vm vm-version + vm:ip vm:sp vm:fp vm:last-ip + + vm-load vm-option set-vm-option! vm-version vm-stats + vms:time vms:clock + + vm-trace-frame + vm-next-hook vm-apply-hook vm-boot-hook vm-return-hook + vm-break-hook vm-exit-hook vm-halt-hook vm-enter-hook)) + +(load-extension "libguile" "scm_init_vm") + +(define (vms:time stat) (vector-ref stat 0)) +(define (vms:clock stat) (vector-ref stat 1)) + +(define (vm-load vm objcode) + (vm (make-program objcode))) diff --git a/module/system/xref.scm b/module/system/xref.scm new file mode 100644 index 000000000..906ec8e4a --- /dev/null +++ b/module/system/xref.scm @@ -0,0 +1,182 @@ +;;;; Copyright (C) 2009 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2.1 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; + + +(define-module (system xref) + #:use-module (system base pmatch) + #:use-module (system base compile) + #:use-module (system vm program) + #:use-module (srfi srfi-1) + #:export (*xref-ignored-modules* + procedure-callees + procedure-callers)) + +(define (program-callee-rev-vars prog) + (define (cons-uniq x y) + (if (memq x y) y (cons x y))) + (cond + ((program-objects prog) + => (lambda (objects) + (let ((n (vector-length objects)) + (progv (make-vector (vector-length objects) #f)) + (asm (decompile (program-objcode prog) #:to 'assembly))) + (pmatch asm + ((load-program ,nargs ,nrest ,nlocs ,labels ,len . ,body) + (for-each + (lambda (x) + (pmatch x + ((toplevel-ref ,n) (vector-set! progv n #t)) + ((toplevel-set ,n) (vector-set! progv n #t)))) + body))) + (let lp ((i 0) (out '())) + (cond + ((= i n) out) + ((program? (vector-ref objects i)) + (lp (1+ i) + (fold cons-uniq out + (program-callee-rev-vars (vector-ref objects i))))) + ((vector-ref progv i) + (let ((obj (vector-ref objects i))) + (if (variable? obj) + (lp (1+ i) (cons-uniq obj out)) + ;; otherwise it's an unmemoized binding + (pmatch obj + (,sym (guard (symbol? sym)) + (let ((v (module-variable (or (program-module prog) + the-root-module) + sym))) + (lp (1+ i) (if v (cons-uniq v out) out)))) + ((,mod ,sym ,public?) + ;; hm, hacky. + (let* ((m (nested-ref the-root-module + (append '(%app modules) mod))) + (v (and m + (module-variable + (if public? + (module-public-interface m) + m) + sym)))) + (lp (1+ i) + (if v (cons-uniq v out) out)))))))) + (else (lp (1+ i) out))))))) + (else '()))) + +(define (procedure-callee-rev-vars proc) + (cond + ((program? proc) (program-callee-rev-vars proc)) + (else '()))) + +(define (procedure-callees prog) + "Evaluates to a list of the given program callees." + (let lp ((in (procedure-callee-rev-vars prog)) (out '())) + (cond ((null? in) out) + ((variable-bound? (car in)) + (lp (cdr in) (cons (variable-ref (car in)) out))) + (else (lp (cdr in) out))))) + +;; var -> ((module-name caller ...) ...) +(define *callers-db* #f) +;; module-name -> (callee ...) +(define *module-callees-db* (make-hash-table)) +;; (module-name ...) +(define *tainted-modules* '()) + +(define *xref-ignored-modules* '((value-history))) +(define (on-module-modified m) + (let ((name (module-name m))) + (if (and (not (member name *xref-ignored-modules*)) + (not (member name *tainted-modules*)) + (pair? name)) + (set! *tainted-modules* (cons name *tainted-modules*))))) + +(define (add-caller callee caller mod-name) + (let ((all-callers (hashq-ref *callers-db* callee))) + (if (not all-callers) + (hashq-set! *callers-db* callee `((,mod-name ,caller))) + (let ((callers (assoc mod-name all-callers))) + (if callers + (if (not (member caller callers)) + (set-cdr! callers (cons caller (cdr callers)))) + (hashq-set! *callers-db* callee + (cons `(,mod-name ,caller) all-callers))))))) + +(define (forget-callers callee mod-name) + (hashq-set! *callers-db* callee + (assoc-remove! (hashq-ref *callers-db* callee '()) mod-name))) + +(define (add-callees callees mod-name) + (hash-set! *module-callees-db* mod-name + (append callees (hash-ref *module-callees-db* mod-name '())))) + +(define (untaint-modules) + (define (untaint m) + (for-each (lambda (callee) (forget-callers callee m)) + (hash-ref *module-callees-db* m '())) + (ensure-callers-db m)) + (ensure-callers-db #f) + (for-each untaint *tainted-modules*) + (set! *tainted-modules* '())) + +(define (ensure-callers-db mod-name) + (let ((mod (and mod-name (resolve-module mod-name))) + (visited #f)) + (define (visit-variable var recurse mod-name) + (if (variable-bound? var) + (let ((x (variable-ref var))) + (cond + ((and visited (hashq-ref visited x))) + ((procedure? x) + (if visited (hashq-set! visited x #t)) + (let ((callees (filter variable-bound? + (procedure-callee-rev-vars x)))) + (for-each (lambda (callee) + (add-caller callee x mod-name)) + callees) + (add-callees callees mod-name))) + ((and recurse (module? x)) + (visit-module x #t)))))) + + (define (visit-module mod recurse) + (if visited (hashq-set! visited mod #t)) + (if (not (memq on-module-modified (module-observers mod))) + (module-observe mod on-module-modified)) + (let ((name (module-name mod))) + (module-for-each (lambda (sym var) + (visit-variable var recurse name)) + mod))) + + (cond ((and (not mod-name) (not *callers-db*)) + (set! *callers-db* (make-hash-table 1000)) + (set! visited (make-hash-table 1000)) + (visit-module the-root-module #t)) + (mod-name (visit-module mod #f))))) + +(define (procedure-callers var) + "Returns an association list, keyed by module name, of known callers +of the given procedure. The latter can specified directly as a +variable, a symbol (which gets resolved in the current module) or a +pair of the form (module-name . variable-name), " + (let ((v (cond ((variable? var) var) + ((symbol? var) (module-variable (current-module) var)) + (else + (pmatch var + ((,modname . ,sym) + (module-variable (resolve-module modname) sym)) + (else + (error "expected a variable, symbol, or (modname . sym)" var))))))) + (untaint-modules) + (hashq-ref *callers-db* v '()))) |