/local-lisp/slime/contrib/swank-kawa.scm
Scheme | 2174 lines | 1738 code | 251 blank | 185 comment | 2 complexity | d55a8867a508e1d528cdf1f8c1e0d728 MD5 | raw file
Possible License(s): GPL-3.0, CC-BY-SA-4.0, GPL-2.0, Unlicense
- ;;;; swank-kawa.scm --- Swank server for Kawa
- ;;;
- ;;; Copyright (C) 2007 Helmut Eller
- ;;;
- ;;; This file is licensed under the terms of the GNU General Public
- ;;; License as distributed with Emacs (press C-h C-c for details).
- ;;;; Installation
- ;;
- ;; 1. You need Kawa (SVN version)
- ;; and a Sun JVM with debugger support.
- ;; 2. Compile this file with:
- ;; kawa -e '(compile-file "swank-kawa.scm" "swank-kawa")'
- ;; 3. Add something like this to your .emacs:
- #|
- ;; Kawa and the debugger classes (tools.jar) must be in the classpath.
- ;; You also need to start the debug agent.
- (setq slime-lisp-implementations
- '((kawa ("java"
- "-cp" "/opt/kawa/kawa-svn:/opt/java/jdk1.6.0/lib/tools.jar"
- "-agentlib:jdwp=transport=dt_socket,server=y,suspend=n"
- "kawa.repl" "-s")
- :init kawa-slime-init)))
- (defun kawa-slime-init (file _)
- (setq slime-protocol-version 'ignore)
- (let ((zip ".../slime/contrib/swank-kawa.zip")) ; <-- insert the right path
- (format "%S\n"
- `(begin (load ,(expand-file-name zip)) (start-swank ,file)))))
- |#
- ;; 4. Start everything with M-- M-x slime kawa
- ;;
- ;;
- ;;;; Module declaration
- (module-export start-swank create-swank-server swank-java-source-path)
- (module-static #t)
- (module-compile-options
- warn-invoke-unknown-method: #t
- warn-undefined-variable: #t
- )
- (require 'hash-table)
- ;;;; Macros ()
- (define-syntax df
- (syntax-rules (=>)
- ((df name (args ... => return-type) body ...)
- (define (name args ...) :: return-type body ...))
- ((df name (args ...) body ...)
- (define (name args ...) body ...))))
- (define-syntax fun
- (syntax-rules ()
- ((fun (args ...) body ...)
- (lambda (args ...) body ...))))
- (define-syntax fin
- (syntax-rules ()
- ((fin body handler ...)
- (try-finally body (seq handler ...)))))
- (define-syntax seq
- (syntax-rules ()
- ((seq body ...)
- (begin body ...))))
- (define-syntax esc
- (syntax-rules ()
- ((esc abort body ...)
- (let* ((key (<symbol>))
- (abort (lambda (val) (throw key val))))
- (catch key
- (lambda () body ...)
- (lambda (key val) val))))))
- (define-syntax !
- (syntax-rules ()
- ((! name obj args ...)
- (invoke obj 'name args ...))))
- (define-syntax !!
- (syntax-rules ()
- ((!! name1 name2 obj args ...)
- (! name1 (! name2 obj args ...)))))
- (define-syntax @
- (syntax-rules ()
- ((@ name obj)
- (field obj 'name))))
- (define-syntax while
- (syntax-rules ()
- ((while exp body ...)
- (do () ((not exp)) body ...))))
- (define-syntax dotimes
- (syntax-rules ()
- ((dotimes (i n result) body ...)
- (let ((max :: <int> n))
- (do ((i :: <int> 0 (as <int> (+ i 1))))
- ((= i max) result)
- body ...)))
- ((dotimes (i n) body ...)
- (dotimes (i n #f) body ...))))
- (define-syntax dolist
- (syntax-rules ()
- ((dolist (e list) body ... )
- (for ((e list)) body ...))))
- (define-syntax for
- (syntax-rules ()
- ((for ((var iterable)) body ...)
- (let ((iter (! iterator iterable)))
- (while (! has-next iter)
- ((lambda (var) body ...)
- (! next iter)))))))
- (define-syntax packing
- (syntax-rules ()
- ((packing (var) body ...)
- (let ((var :: <list> '()))
- (let ((var (lambda (v) (set! var (cons v var)))))
- body ...)
- (reverse! var)))))
- ;;(define-syntax loop
- ;; (syntax-rules (for = then collect until)
- ;; ((loop for var = init then step until test collect exp)
- ;; (packing (pack)
- ;; (do ((var init step))
- ;; (test)
- ;; (pack exp))))
- ;; ((loop while test collect exp)
- ;; (packing (pack) (while test (pack exp))))))
- (define-syntax with
- (syntax-rules ()
- ((with (vars ... (f args ...)) body ...)
- (f args ... (lambda (vars ...) body ...)))))
- (define-syntax pushf
- (syntax-rules ()
- ((pushf value var)
- (set! var (cons value var)))))
- (define-syntax ==
- (syntax-rules ()
- ((== x y)
- (eq? x y))))
- (define-syntax set
- (syntax-rules ()
- ((set x y)
- (let ((tmp y))
- (set! x tmp)
- tmp))
- ((set x y more ...)
- (begin (set! x y) (set more ...)))))
- (define-syntax assert
- (syntax-rules ()
- ((assert test)
- (seq
- (when (not test)
- (error "Assertion failed" 'test))
- 'ok))
- ((assert test fstring args ...)
- (seq
- (when (not test)
- (error "Assertion failed" 'test (format #f fstring args ...)))
- 'ok))))
- (define-syntax mif
- (syntax-rules (quote unquote _)
- ((mif ('x value) then else)
- (if (equal? 'x value) then else))
- ((mif (,x value) then else)
- (if (eq? x value) then else))
- ((mif (() value) then else)
- (if (eq? value '()) then else))
- #| This variant produces no lambdas but breaks the compiler
- ((mif ((p . ps) value) then else)
- (let ((tmp value)
- (fail? :: <int> 0)
- (result #!null))
- (if (instance? tmp <pair>)
- (let ((tmp :: <pair> tmp))
- (mif (p (@ car tmp))
- (mif (ps (@ cdr tmp))
- (set! result then)
- (set! fail? -1))
- (set! fail? -1)))
- (set! fail? -1))
- (if (= fail? 0) result else)))
- |#
- ((mif ((p . ps) value) then else)
- (let ((fail (lambda () else))
- (tmp value))
- (if (instance? tmp <pair>)
- (let ((tmp :: <pair> tmp))
- (mif (p (@ car tmp))
- (mif (ps (@ cdr tmp))
- then
- (fail))
- (fail)))
- (fail))))
- ((mif (_ value) then else)
- then)
- ((mif (var value) then else)
- (let ((var value)) then))
- ((mif (pattern value) then)
- (mif (pattern value) then (values)))))
- (define-syntax mcase
- (syntax-rules ()
- ((mcase exp (pattern body ...) more ...)
- (let ((tmp exp))
- (mif (pattern tmp)
- (begin body ...)
- (mcase tmp more ...))))
- ((mcase exp) (ferror "mcase failed ~s\n~a" 'exp (pprint-to-string exp)))))
- (define-syntax mlet
- (syntax-rules ()
- ((mlet (pattern value) body ...)
- (let ((tmp value))
- (mif (pattern tmp)
- (begin body ...)
- (error "mlet failed" tmp))))))
- (define-syntax mlet*
- (syntax-rules ()
- ((mlet* () body ...) (begin body ...))
- ((mlet* ((pattern value) ms ...) body ...)
- (mlet (pattern value) (mlet* (ms ...) body ...)))))
- (define-syntax typecase
- (syntax-rules (::)
- ((typecase var (type body ...) ...)
- (cond ((instance? var type)
- (let ((var :: type var))
- body ...))
- ...
- (else (error "typecase failed" var
- (! getClass (as <object> var))))))))
- (define-syntax ignore-errors
- (syntax-rules ()
- ((ignore-errors body ...)
- (try-catch (begin body ...)
- (v <java.lang.Exception> #f)))))
- ;;(define-syntax dc
- ;; (syntax-rules ()
- ;; ((dc name () %% (props ...) prop more ...)
- ;; (dc name () %% (props ... (prop <object>)) more ...))
- ;; ;;((dc name () %% (props ...) (prop type) more ...)
- ;; ;; (dc name () %% (props ... (prop type)) more ...))
- ;; ((dc name () %% ((prop type) ...))
- ;; (define-simple-class name ()
- ;; ((*init* (prop :: type) ...)
- ;; (set (field (this) 'prop) prop) ...)
- ;; (prop :type type) ...))
- ;; ((dc name () props ...)
- ;; (dc name () %% () props ...))))
- ;;;; Aliases
- (define-alias <server-socket> <java.net.ServerSocket>)
- (define-alias <socket> <java.net.Socket>)
- (define-alias <in> <java.io.InputStreamReader>)
- (define-alias <out> <java.io.OutputStreamWriter>)
- (define-alias <file> <java.io.File>)
- (define-alias <str> <java.lang.String>)
- (define-alias <builder> <java.lang.StringBuilder>)
- (define-alias <throwable> <java.lang.Throwable>)
- (define-alias <source-error> <gnu.text.SourceError>)
- (define-alias <module-info> <gnu.expr.ModuleInfo>)
- (define-alias <iterable> <java.lang.Iterable>)
- (define-alias <thread> <java.lang.Thread>)
- (define-alias <queue> <java.util.concurrent.LinkedBlockingQueue>)
- (define-alias <exchanger> <java.util.concurrent.Exchanger>)
- (define-alias <timeunit> <java.util.concurrent.TimeUnit>)
- (define-alias <vm> <com.sun.jdi.VirtualMachine>)
- (define-alias <mirror> <com.sun.jdi.Mirror>)
- (define-alias <value> <com.sun.jdi.Value>)
- (define-alias <thread-ref> <com.sun.jdi.ThreadReference>)
- (define-alias <obj-ref> <com.sun.jdi.ObjectReference>)
- (define-alias <array-ref> <com.sun.jdi.ArrayReference>)
- (define-alias <str-ref> <com.sun.jdi.StringReference>)
- (define-alias <meth-ref> <com.sun.jdi.Method>)
- (define-alias <class-ref> <com.sun.jdi.ClassType>)
- (define-alias <frame> <com.sun.jdi.StackFrame>)
- (define-alias <field> <com.sun.jdi.Field>)
- (define-alias <local-var> <com.sun.jdi.LocalVariable>)
- (define-alias <location> <com.sun.jdi.Location>)
- (define-alias <absent-exc> <com.sun.jdi.AbsentInformationException>)
- (define-alias <ref-type> <com.sun.jdi.ReferenceType>)
- (define-alias <event> <com.sun.jdi.event.Event>)
- (define-alias <exception-event> <com.sun.jdi.event.ExceptionEvent>)
- (define-alias <step-event> <com.sun.jdi.event.StepEvent>)
- (define-alias <env> <gnu.mapping.Environment>)
- (define-simple-class <chan> ()
- (owner :: <thread> init: (java.lang.Thread:currentThread))
- (peer :: <chan>)
- (queue :: <queue> init: (<queue>))
- (lock init: (<object>)))
- ;;;; Entry Points
- (df create-swank-server (port-number)
- (setup-server port-number announce-port))
- (df start-swank (port-file)
- (let ((announce (fun ((socket <server-socket>))
- (with (f (call-with-output-file port-file))
- (format f "~d\n" (! get-local-port socket))))))
- (spawn (fun ()
- (setup-server 0 announce)))))
- (df setup-server ((port-number <int>) announce)
- (! set-name (current-thread) "swank")
- (let ((s (<server-socket> port-number)))
- (announce s)
- (let ((c (! accept s)))
- (! close s)
- (log "connection: ~s\n" c)
- (fin (dispatch-events c)
- (log "closing socket: ~a\n" s)
- (! close c)))))
- (df announce-port ((socket <server-socket>))
- (log "Listening on port: ~d\n" (! get-local-port socket)))
- ;;;; Event dispatcher
- (define-variable *the-vm* #f)
- (define-variable *last-exception* #f)
- (define-variable *last-stacktrace* #f)
- ;; FIXME: this needs factorization. But I guess the whole idea of
- ;; using bidirectional channels just sucks. Mailboxes owned by a
- ;; single thread to which everybody can send are much easier to use.
- (df dispatch-events ((s <socket>))
- (mlet* ((charset "iso-8859-1")
- (ins (<in> (! getInputStream s) charset))
- (outs (<out> (! getOutputStream s) charset))
- ((in . _) (spawn/chan/catch (fun (c) (reader ins c))))
- ((out . _) (spawn/chan/catch (fun (c) (writer outs c))))
- ((dbg . _) (spawn/chan/catch vm-monitor))
- (user-env (interaction-environment))
- (x (seq
- (! set-flag user-env #t #|<env>:THREAD_SAFE|# 8)
- (! set-flag user-env #f #|<env>:DIRECT_INHERITED_ON_SET|# 16)))
- ((listener . _)
- (spawn/chan (fun (c) (listener c user-env))))
- (inspector #f)
- (threads '())
- (repl-thread #f)
- (extra '())
- (vm (let ((vm #f)) (fun () (or vm (rpc dbg `(get-vm)))))))
- (while #t
- (mlet ((c . event) (recv* (append (list in out dbg listener)
- (if inspector (list inspector) '())
- (map car threads)
- extra)))
- ;;(log "event: ~s\n" event)
- (mcase (list c event)
- ((_ (':emacs-rex ('|swank:debugger-info-for-emacs| from to)
- pkg thread id))
- (send dbg `(debug-info ,thread ,from ,to ,id)))
- ((_ (':emacs-rex ('|swank:throw-to-toplevel|) pkg thread id))
- (send dbg `(throw-to-toplevel ,thread ,id)))
- ((_ (':emacs-rex ('|swank:sldb-continue|) pkg thread id))
- (send dbg `(thread-continue ,thread ,id)))
- ((_ (':emacs-rex ('|swank:frame-source-location| frame)
- pkg thread id))
- (send dbg `(frame-src-loc ,thread ,frame ,id)))
- ((_ (':emacs-rex ('|swank:frame-locals-and-catch-tags| frame)
- pkg thread id))
- (send dbg `(frame-details ,thread ,frame ,id)))
- ((_ (':emacs-rex ('|swank:sldb-disassemble| frame)
- pkg thread id))
- (send dbg `(disassemble-frame ,thread ,frame ,id)))
- ((_ (':emacs-rex ('|swank:backtrace| from to) pkg thread id))
- (send dbg `(thread-frames ,thread ,from ,to ,id)))
- ((_ (':emacs-rex ('|swank:list-threads|) pkg thread id))
- (send dbg `(list-threads ,id)))
- ((_ (':emacs-rex ('|swank:debug-nth-thread| n) _ _ _))
- (send dbg `(debug-nth-thread ,n)))
- ((_ (':emacs-rex ('|swank:quit-thread-browser|) _ _ id))
- (send dbg `(quit-thread-browser ,id)))
- ((_ (':emacs-rex ('|swank:init-inspector| str . _) pkg _ id))
- (set inspector (make-inspector user-env (vm)))
- (send inspector `(init ,str ,id)))
- ((_ (':emacs-rex ('|swank:inspect-frame-var| frame var)
- pkg thread id))
- (mlet ((im . ex) (chan))
- (set inspector (make-inspector user-env (vm)))
- (send dbg `(get-local ,ex ,thread ,frame ,var))
- (send inspector `(init-mirror ,im ,id))))
- ((_ (':emacs-rex ('|swank:inspect-current-condition|) pkg thread id))
- (mlet ((im . ex) (chan))
- (set inspector (make-inspector user-env (vm)))
- (send dbg `(get-exception ,ex ,thread))
- (send inspector `(init-mirror ,im ,id))))
- ((_ (':emacs-rex ('|swank:inspect-nth-part| n) pkg _ id))
- (send inspector `(inspect-part ,n ,id)))
- ((_ (':emacs-rex ('|swank:inspector-pop|) pkg _ id))
- (send inspector `(pop ,id)))
- ((_ (':emacs-rex ('|swank:quit-inspector|) pkg _ id))
- (send inspector `(quit ,id)))
- ((_ (':emacs-interrupt id))
- (let* ((vm (vm))
- (t (find-thread id (map cdr threads) repl-thread vm)))
- (send dbg `(debug-thread ,t))))
- ((_ (':emacs-rex form _ _ id))
- (send listener `(,form ,id)))
- ((_ ('get-vm c))
- (send dbg `(get-vm ,c)))
- ((_ ('get-channel c))
- (mlet ((im . ex) (chan))
- (pushf im extra)
- (send c ex)))
- ((_ ('forward x))
- (send out x))
- ((_ ('set-listener x))
- (set repl-thread x))
- ((_ ('publish-vm vm))
- (set *the-vm* vm))
- )))))
- (df find-thread (id threads listener (vm <vm>))
- (cond ((== id ':repl-thread) listener)
- ((== id 't) listener
- ;;(if (null? threads)
- ;; listener
- ;; (vm-mirror vm (car threads)))
- )
- (#t
- (let ((f (find-if threads
- (fun (t :: <thread>)
- (= id (! uniqueID
- (as <thread-ref> (vm-mirror vm t)))))
- #f)))
- (cond (f (vm-mirror vm f))
- (#t listener))))))
- ;;;; Reader thread
- (df reader ((in <in>) (c <chan>))
- (! set-name (current-thread) "swank-net-reader")
- (let ((rt (gnu.kawa.lispexpr.ReadTable:createInitial))) ; ':' not special
- (while #t
- (send c (decode-message in rt)))))
- (df decode-message ((in <in>) (rt <gnu.kawa.lispexpr.ReadTable>) => <list>)
- (let* ((header (read-chunk in 6))
- (len (java.lang.Integer:parseInt header 16)))
- (call-with-input-string (read-chunk in len)
- (fun ((port <input-port>))
- (%read port rt)))))
- (df read-chunk ((in <in>) (len <int>) => <str>)
- (let ((chars (<char[]> length: len)))
- (let loop ((offset :: <int> 0))
- (cond ((= offset len) (<str> chars))
- (#t (let ((count (! read in chars offset (- len offset))))
- (assert (not (= count -1)) "partial packet")
- (loop (+ offset count))))))))
- ;;; FIXME: not thread safe
- (df %read ((port <gnu.mapping.InPort>) (table <gnu.kawa.lispexpr.ReadTable>))
- (let ((old (gnu.kawa.lispexpr.ReadTable:getCurrent)))
- (try-finally
- (seq (gnu.kawa.lispexpr.ReadTable:setCurrent table)
- (read port))
- (gnu.kawa.lispexpr.ReadTable:setCurrent old))))
- ;;;; Writer thread
- (df writer ((out <out>) (c <chan>))
- (! set-name (current-thread) "swank-net-writer")
- (while #t
- (encode-message out (recv c))))
- (df encode-message ((out <out>) (message <list>))
- (let ((builder (<builder> (as <int> 512))))
- (print-for-emacs message builder)
- (! write out (! toString (format "~6,'0x" (! length builder))))
- (! write out builder)
- (! flush out)))
- (df print-for-emacs (obj (out <builder>))
- (let ((pr (fun (o) (! append out (! toString (format "~s" o)))))
- (++ (fun ((s <string>)) (! append out (! toString s)))))
- (cond ((null? obj) (++ "nil"))
- ((string? obj) (pr obj))
- ((number? obj) (pr obj))
- ;;((keyword? obj) (++ ":") (! append out (to-str obj)))
- ((symbol? obj) (pr obj))
- ((pair? obj)
- (++ "(")
- (let loop ((obj obj))
- (print-for-emacs (car obj) out)
- (let ((cdr (cdr obj)))
- (cond ((null? cdr) (++ ")"))
- ((pair? cdr) (++ " ") (loop cdr))
- (#t (++ " . ") (print-for-emacs cdr out) (++ ")"))))))
- (#t (error "Unprintable object" obj)))))
- ;;;; SLIME-EVAL
- (df eval-for-emacs ((form <list>) env (id <int>) (c <chan>))
- ;;(! set-uncaught-exception-handler (current-thread)
- ;; (<ucex-handler> (fun (t e) (reply-abort c id))))
- (reply c (%eval form env) id))
- (define-variable *slime-funs*)
- (set *slime-funs* (tab))
- (df %eval (form env)
- (apply (lookup-slimefun (car form) *slime-funs*) env (cdr form)))
- (df lookup-slimefun ((name <symbol>) tab)
- ;; name looks like '|swank:connection-info|
- (let* ((str (symbol->string name))
- (sub (substring str 6 (string-length str))))
- (or (get tab (string->symbol sub) #f)
- (ferror "~a not implemented" sub))))
-
- (define-syntax defslimefun
- (syntax-rules ()
- ((defslimefun name (args ...) body ...)
- (seq
- (df name (args ...) body ...)
- (put *slime-funs* 'name name)))))
- (defslimefun connection-info ((env <env>))
- (let ((prop java.lang.System:getProperty))
- `(:pid
- 0
- :style :spawn
- :lisp-implementation (:type "Kawa" :name "kawa"
- :version ,(scheme-implementation-version))
- :machine (:instance ,(prop "java.vm.name") :type ,(prop "os.name")
- :version ,(prop "java.runtime.version"))
- :features ()
- :package (:name "??" :prompt ,(! getName env)))))
-
- ;;;; Listener
- (df listener ((c <chan>) (env <env>))
- (! set-name (current-thread) "swank-listener")
- (log "listener: ~s ~s ~s ~s\n"
- (current-thread) ((current-thread):hashCode) c env)
- (let ((out (make-swank-outport (rpc c `(get-channel)))))
- ;;(set (current-output-port) out)
- (let ((vm (as <vm> (rpc c `(get-vm)))))
- (send c `(set-listener ,(vm-mirror vm (current-thread))))
- (enable-uncaught-exception-events vm))
- (rpc c `(get-vm))
- (listener-loop c env out)))
- (df listener-loop ((c <chan>) (env <env>) port)
- (while (not (nul? c))
- ;;(log "listener-loop: ~s ~s\n" (current-thread) c)
- (mlet ((form id) (recv c))
- (let ((restart (fun ()
- (close-output-port port)
- (reply-abort c id)
- (send (car (spawn/chan
- (fun (cc)
- (listener (recv cc) env))))
- c)
- (set c #!null))))
- (! set-uncaught-exception-handler (current-thread)
- (<ucex-handler> (fun (t e) (restart))))
- (try-catch
- (let* ((val (%eval form env)))
- (force-output)
- (reply c val id))
- (ex <listener-abort>
- (let ((flag (java.lang.Thread:interrupted)))
- (log "listener-abort: ~s ~a\n" ex flag))
- (restart)))))))
- (defslimefun create-repl (env #!rest _)
- (list "user" "user"))
- (defslimefun interactive-eval (env str)
- (values-for-echo-area (eval (read-from-string str) env)))
- (defslimefun interactive-eval-region (env (s <string>))
- (with (port (call-with-input-string s))
- (values-for-echo-area
- (let next ((result (values)))
- (let ((form (read port)))
- (cond ((== form #!eof) result)
- (#t (next (eval form env)))))))))
- (defslimefun listener-eval (env string)
- (let* ((form (read-from-string string))
- (list (values-to-list (eval form env))))
- `(:values ,@(map pprint-to-string list))))
- (defslimefun pprint-eval (env string)
- (let* ((form (read-from-string string))
- (l (values-to-list (eval form env))))
- (apply cat (map pprint-to-string l))))
- (df call-with-abort (f)
- (try-catch (f) (ex <throwable> (exception-message ex))))
- (df exception-message ((ex <throwable>))
- (typecase ex
- (<kawa.lang.NamedException> (! to-string ex))
- (<throwable> (format "~a: ~a"
- (class-name-sans-package ex)
- (! getMessage ex)))))
- (df values-for-echo-area (values)
- (let ((values (values-to-list values)))
- (format "~:[=> ~{~s~^, ~}~;; No values~]" (null? values) values)))
- ;;;; Compilation
- (defslimefun compile-file-for-emacs (env (filename <str>) load?
- #!optional options)
- (let ((jar (cat (path-sans-extension (filepath filename)) ".jar")))
- (wrap-compilation
- (fun ((m <gnu.text.SourceMessages>))
- (kawa.lang.CompileFile:read filename m))
- jar (if (lisp-bool load?) env #f) #f)))
- (df wrap-compilation (f jar env delete?)
- (let ((start-time (current-time))
- (messages (<gnu.text.SourceMessages>)))
- (try-catch
- (let ((c (as <gnu.expr.Compilation> (f messages))))
- (set (@ explicit c) #t)
- (! compile-to-archive c (! get-module c) jar))
- (ex <throwable>
- (log "error during compilation: ~a\n~a" ex (! getStackTrace ex))
- (! error messages (as <char> #\f)
- (to-str (exception-message ex)) #!null)))
- (log "compilation done.\n")
- (let ((success? (zero? (! get-error-count messages))))
- (when (and env success?)
- (log "loading ...\n")
- (eval `(load ,jar) env)
- (log "loading ... done.\n"))
- (when delete?
- (ignore-errors (delete-file jar)))
- (let ((end-time (current-time)))
- (list ':compilation-result
- (compiler-notes-for-emacs messages)
- (if success? 't 'nil)
- (/ (- end-time start-time) 1000.0))))))
- (defslimefun compile-string-for-emacs (env string buffer offset dir)
- (wrap-compilation
- (fun ((m <gnu.text.SourceMessages>))
- (let ((c (as <gnu.expr.Compilation>
- (call-with-input-string
- string
- (fun ((p <gnu.mapping.InPort>))
- (! set-path p
- (format "~s"
- `(buffer ,buffer offset ,offset str ,string)))
- (kawa.lang.CompileFile:read p m))))))
- (let ((o (@ currentOptions c)))
- (! set o "warn-invoke-unknown-method" #t)
- (! set o "warn-undefined-variable" #t))
- (let ((m (! getModule c)))
- (! set-name m (format "<emacs>:~a/~a" buffer (current-time))))
- c))
- "/tmp/kawa-tmp.zip" env #t))
- (df compiler-notes-for-emacs ((messages <gnu.text.SourceMessages>))
- (packing (pack)
- (do ((e (! get-errors messages) (@ next e)))
- ((nul? e))
- (pack (source-error>elisp e)))))
- (df source-error>elisp ((e <source-error>) => <list>)
- (list ':message (to-string (@ message e))
- ':severity (case (integer->char (@ severity e))
- ((#\e #\f) ':error)
- ((#\w) ':warning)
- (else ':note))
- ':location (error-loc>elisp e)))
- (df error-loc>elisp ((e <source-error>))
- (cond ((nul? (@ filename e)) `(:error "No source location"))
- ((! starts-with (@ filename e) "(buffer ")
- (mlet (('buffer b 'offset o 'str s) (read-from-string (@ filename e)))
- `(:location (:buffer ,b)
- (:position ,(+ o (line>offset (1- (@ line e)) s)
- (1- (@ column e))))
- nil)))
- (#t
- `(:location (:file ,(to-string (@ filename e)))
- (:line ,(@ line e) ,(1- (@ column e)))
- nil))))
- (df line>offset ((line <int>) (s <str>) => <int>)
- (let ((offset :: <int> 0))
- (dotimes (i line)
- (set offset (! index-of s (as <char> #\newline) offset))
- (assert (>= offset 0))
- (set offset (as <int> (+ offset 1))))
- (log "line=~a offset=~a\n" line offset)
- offset))
- (defslimefun load-file (env filename)
- (format "Loaded: ~a => ~s" filename (eval `(load ,filename) env)))
- ;;;; Completion
- (defslimefun simple-completions (env (pattern <str>) _)
- (let* ((env (as <gnu.mapping.InheritingEnvironment> env))
- (matches (packing (pack)
- (let ((iter (! enumerate-all-locations env)))
- (while (! has-next iter)
- (let ((l (! next-location iter)))
- (typecase l
- (<gnu.mapping.NamedLocation>
- (let ((name (!! get-name get-key-symbol l)))
- (when (! starts-with name pattern)
- (pack name)))))))))))
- `(,matches ,(cond ((null? matches) pattern)
- (#t (fold+ common-prefix matches))))))
- (df common-prefix ((s1 <str>) (s2 <str>) => <str>)
- (let ((limit (min (! length s1) (! length s2))))
- (let loop ((i 0))
- (cond ((or (= i limit)
- (not (== (! char-at s1 i)
- (! char-at s2 i))))
- (! substring s1 0 i))
- (#t (loop (1+ i)))))))
- (df fold+ (f list)
- (let loop ((s (car list))
- (l (cdr list)))
- (cond ((null? l) s)
- (#t (loop (f s (car l)) (cdr l))))))
- ;;; Quit
- (defslimefun quit-lisp (env)
- (exit))
- ;;(defslimefun set-default-directory (env newdir))
- ;;;; Dummy defs
- (defslimefun buffer-first-change (#!rest y) '())
- (defslimefun swank-require (#!rest y) '())
- ;;;; arglist
- (defslimefun operator-arglist (env name #!rest _)
- (mcase (try-catch `(ok ,(eval (read-from-string name) env))
- (ex <throwable> 'nil))
- (('ok obj)
- (mcase (arglist obj)
- ('#f 'nil)
- ((args rtype)
- (format "(~a~{~^ ~a~})~a" name
- (map (fun (e)
- (if (equal (cadr e) "java.lang.Object") (car e) e))
- args)
- (if (equal rtype "java.lang.Object")
- ""
- (format " => ~a" rtype))))))
- (_ 'nil)))
- (df arglist (obj)
- (typecase obj
- (<gnu.expr.ModuleMethod>
- (let* ((mref (module-method>meth-ref obj)))
- (list (mapi (! arguments mref)
- (fun ((v <local-var>))
- (list (! name v) (! typeName v))))
- (! returnTypeName mref))))
- (<object> #f)))
- ;;;; M-.
- (defslimefun find-definitions-for-emacs (env name)
- (mcase (try-catch `(ok ,(eval (read-from-string name) env))
- (ex <throwable> `(error ,(exception-message ex))))
- (('ok obj) (mapi (all-definitions obj)
- (fun (d)
- `(,(format "~a" d) ,(src-loc>elisp (src-loc d))))))
- (('error msg) `((,name (:error ,msg))))))
- (define-simple-class <swank-location> (<location>)
- (file init: #f)
- (line init: #f)
- ((*init* file name)
- (set (@ file (this)) file)
- (set (@ line (this)) line))
- ((lineNumber) :: <int> (or line (absent)))
- ((lineNumber (s <str>)) :: int (! lineNumber (this)))
- ((method) :: <meth-ref> (absent))
- ((sourcePath) :: <str> (or file (absent)))
- ((sourcePath (s <str>)) :: <str> (! sourcePath (this)))
- ((sourceName) :: <str> (absent))
- ((sourceName (s <str>)) :: <str> (! sourceName (this)))
- ((declaringType) :: <ref-type> (absent))
- ((codeIndex) :: <long> -1)
- ((virtualMachine) :: <vm> *the-vm*)
- ((compareTo o) :: <int>
- (typecase o
- (<location> (- (! codeIndex (this)) (! codeIndex o))))))
- (df absent () (primitive-throw (<absent-exc>)))
- (df all-definitions (o)
- (typecase o
- (<gnu.expr.ModuleMethod> (list o))
- (<gnu.expr.GenericProc> (append (mappend all-definitions (gf-methods o))
- (let ((s (! get-setter o)))
- (if s (all-definitions s) '()))))
- (<java.lang.Class> (list o))
- (<gnu.mapping.Procedure> (all-definitions (! get-class o)))
- (<kawa.lang.Macro> (list o))
- (<gnu.bytecode.ObjectType> (all-definitions (! getReflectClass o)))
- (<java.lang.Object> '())
- ))
- (df gf-methods ((f <gnu.expr.GenericProc>))
- (let* ((o :: <obj-ref> (vm-mirror *the-vm* f))
- (f (! field-by-name (! reference-type o) "methods"))
- (ms (vm-demirror *the-vm* (! get-value o f))))
- (filter (array-to-list ms) (fun (x) (not (nul? x))))))
- (df src-loc (o => <location>)
- (typecase o
- (<gnu.expr.ModuleMethod> (module-method>src-loc o))
- (<gnu.expr.GenericProc> (<swank-location> #f #f))
- (<java.lang.Class> (class>src-loc o))
- (<kawa.lang.Macro> (<swank-location> #f #f))))
- (df module-method>src-loc ((f <gnu.expr.ModuleMethod>))
- (! location (module-method>meth-ref f)))
- (df module-method>meth-ref ((f <gnu.expr.ModuleMethod>) => <meth-ref>)
- (let ((module (! reference-type
- (as <obj-ref> (vm-mirror *the-vm* (@ module f)))))
- (name (mangled-name f)))
- (as <meth-ref> (1st (! methods-by-name module name)))))
- (df mangled-name ((f <gnu.expr.ModuleMethod>))
- (let ((name (gnu.expr.Compilation:mangleName (! get-name f))))
- (if (= (! maxArgs f) -1)
- (cat name "$V")
- name)))
- (df class>src-loc ((c <java.lang.Class>) => <location>)
- (let* ((type (! reflectedType (as <com.sun.jdi.ClassObjectReference>
- (vm-mirror *the-vm* c))))
- (locs (! all-line-locations type)))
- (cond ((not (! isEmpty locs)) (1st locs))
- (#t (<swank-location> (1st (! source-paths type #!null))
- #f)))))
- (df src-loc>elisp ((l <location>))
- (df src-loc>list ((l <location>))
- (list (ignore-errors (! source-name l))
- (ignore-errors (! source-path l))
- (ignore-errors (! line-number l))))
- (mcase (src-loc>list l)
- ((name path line)
- (cond ((not path)
- `(:error ,(call-with-abort (fun () (! source-path l)))))
- ((! starts-with (as <str> path) "(buffer ")
- (mlet (('buffer b 'offset o 'str s) (read-from-string path))
- `(:location (:buffer ,b)
- (:position ,(+ o (line>offset line s)))
- nil)))
- (#t
- `(:location ,(or (find-file-in-path name (source-path))
- (find-file-in-path path (source-path))
- (ferror "Can't find source-path: ~s ~s ~a"
- path name (source-path)))
- (:line ,(or line -1)) ()))))))
- (df src-loc>str ((l <location>))
- (cond ((nul? l) "<null-location>")
- (#t (format "~a ~a ~a"
- (or (ignore-errors (! source-path l))
- (ignore-errors (! source-name l))
- (ignore-errors (!! name declaring-type l)))
- (ignore-errors (!! name method l))
- (ignore-errors (! lineNumber l))))))
- (df ferror (fstring #!rest args)
- (primitive-throw (<java.lang.Error> (to-str (apply format fstring args)))))
- ;;;;;; class-path hacking
- (df find-file-in-path ((filename <str>) (path <list>))
- (let ((f (<file> filename)))
- (cond ((! isAbsolute f) `(:file ,filename))
- (#t (let ((result #f))
- (find-if path (fun (dir)
- (let ((x (find-file-in-dir f dir)))
- (set result x)))
- #f)
- result)))))
- (df find-file-in-dir ((file <file>) (dir <str>))
- (let ((filename (! getPath file)))
- (or (let ((child (<file> (<file> dir) filename)))
- (and (! exists child)
- `(:file ,(! getPath child))))
- (try-catch
- (and (not (nul? (! getEntry (<java.util.zip.ZipFile> dir) filename)))
- `(:zip ,dir ,filename))
- (ex <throwable> #f)))))
- (define swank-java-source-path
- (let ((jre-home (<java.lang.System>:getProperty "java.home")))
- (list (! get-path (<file> (! get-parent (<file> jre-home)) "src.zip"))
- )))
- (df source-path ()
- (mlet ((base) (search-path-prop "user.dir"))
- (append
- (list base)
- (map (fun ((s <str>))
- (let ((f (<file> s)))
- (cond ((! isAbsolute f) s)
- (#t (<file> (as <str> base) s):path))))
- (class-path))
- swank-java-source-path)))
- (df class-path ()
- (append (search-path-prop "java.class.path")
- (search-path-prop "sun.boot.class.path")))
- (df search-path-prop ((name <str>))
- (array-to-list (! split (java.lang.System:getProperty name)
- <file>:pathSeparator)))
- ;;;; Disassemble
- (defslimefun disassemble-form (env form)
- (mcase (read-from-string form)
- (('quote name)
- (let ((f (eval name env)))
- (typecase f
- (<gnu.expr.ModuleMethod>
- (disassemble (module-method>meth-ref f))))))))
- (df disassemble ((mr <meth-ref>) => <str>)
- (with-sink #f (fun (out) (disassemble-meth-ref mr out))))
- (df disassemble-meth-ref ((mr <meth-ref>) (out <java.io.PrintWriter>))
- (let* ((t (! declaring-type mr)))
- (disas-header mr out)
- (disas-code (! constant-pool t)
- (! constant-pool-count t)
- (! bytecodes mr)
- out)))
- (df disas-header ((mr <meth-ref>) (out <java.io.PrintWriter>))
- (let* ((++ (fun ((str <str>)) (! write out str)))
- (? (fun (flag str) (if flag (++ str)))))
- (? (! is-static mr) "static ")
- (? (! is-final mr) "final ")
- (? (! is-private mr) "private ")
- (? (! is-protected mr) "protected ")
- (? (! is-public mr) "public ")
- (++ (! name mr)) (++ (! signature mr)) (++ "\n")))
- (df disas-code ((cpool <byte[]>) (cpoolcount <int>) (bytecode <byte[]>)
- (out <java.io.PrintWriter>))
- (let* ((ct (<gnu.bytecode.ClassType> "foo"))
- (met (! addMethod ct "bar" 0))
- (ca (<gnu.bytecode.CodeAttr> met))
- (constants (let* ((bs (<java.io.ByteArrayOutputStream>))
- (s (<java.io.DataOutputStream> bs)))
- (! write-short s cpoolcount)
- (! write s cpool)
- (! flush s)
- (! toByteArray bs))))
- (vm-set-slot *the-vm* ct "constants"
- (<gnu.bytecode.ConstantPool>
- (<java.io.DataInputStream>
- (<java.io.ByteArrayInputStream>
- constants))))
- (! setCode ca bytecode)
- (let ((w (<gnu.bytecode.ClassTypeWriter> ct out 0)))
- (! print ca w)
- (! flush w))))
- (df with-sink (sink (f <function>))
- (cond ((instance? sink <java.io.PrintWriter>) (f sink))
- ((== sink #t) (f (as <java.io.PrintWriter> (current-output-port))))
- ((== sink #f)
- (let* ((buffer (<java.io.StringWriter>))
- (out (<java.io.PrintWriter> buffer)))
- (f out)
- (! flush out)
- (! toString buffer)))
- (#t (ferror "Invalid sink designator: ~s" sink))))
- (df test-disas ((c <str>) (m <str>))
- (let* ((vm (as <vm> *the-vm*))
- (c (as <ref-type> (1st (! classes-by-name vm c))))
- (m (as <meth-ref> (1st (! methods-by-name c m)))))
- (with-sink #f (fun (out) (disassemble-meth-ref m out)))))
- ;; (test-disas "java.lang.Class" "toString")
- ;;;; Macroexpansion
- (defslimefun swank-macroexpand-1 (env s) (%swank-macroexpand s))
- (defslimefun swank-macroexpand (env s) (%swank-macroexpand s))
- (defslimefun swank-macroexpand-all (env s) (%swank-macroexpand s))
- (df %swank-macroexpand (string)
- (pprint-to-string (%macroexpand (read-from-string string))))
- (df %macroexpand (sexp)
- (let ((tr :: kawa.lang.Translator (gnu.expr.Compilation:getCurrent)))
- (! rewrite tr `(begin ,sexp))))
- ;;;; Inspector
- (define-simple-class <inspector-state> ()
- (object init: #!null)
- (parts :: <java.util.ArrayList> init: (<java.util.ArrayList>) )
- (stack :: <list> init: '())
- (content :: <list> init: '()))
- (df make-inspector (env (vm <vm>) => <chan>)
- (car (spawn/chan (fun (c) (inspector c env vm)))))
- (df inspector ((c <chan>) env (vm <vm>))
- (! set-name (current-thread) "inspector")
- (let ((state :: <inspector-state> (<inspector-state>))
- (open #t))
- (while open
- (mcase (recv c)
- (('init str id)
- (set state (<inspector-state>))
- (let ((obj (try-catch (eval (read-from-string str) env)
- (ex <throwable> ex))))
- (reply c (inspect-object obj state vm) id)))
- (('init-mirror cc id)
- (set state (<inspector-state>))
- (let* ((mirror (recv cc))
- (obj (vm-demirror vm mirror)))
- (reply c (inspect-object obj state vm) id)))
- (('inspect-part n id)
- (let ((part (! get (@ parts state) n)))
- (reply c (inspect-object part state vm) id)))
- (('pop id)
- (reply c (inspector-pop state vm) id))
- (('quit id)
- (reply c 'nil id)
- (set open #f))))))
- (df inspect-object (obj (state <inspector-state>) (vm <vm>))
- (set (@ object state) obj)
- (set (@ parts state) (<java.util.ArrayList>))
- (pushf obj (@ stack state))
- (set (@ content state) (inspector-content
- `("class: " (:value ,(! getClass obj)) "\n"
- ,@(inspect obj vm))
- state))
- (cond ((nul? obj) (list ':title "#!null" ':id 0 ':content `()))
- (#t
- (list ':title (pprint-to-string obj)
- ':id (assign-index obj state)
- ':content (let ((c (@ content state)))
- (content-range c 0 (len c)))))))
- (df inspect (obj vm)
- (let* ((obj (as <obj-ref> (vm-mirror vm obj))))
- (packing (pack)
- (typecase obj
- (<array-ref>
- (let ((i 0))
- (iter (! getValues obj)
- (fun ((v <value>))
- (pack (format "~d: " i))
- (set i (1+ i))
- (pack `(:value ,(vm-demirror vm v)))
- (pack "\n")))))
- (<obj-ref>
- (let* ((type (! referenceType obj))
- (fields (! allFields type))
- (values (! getValues obj fields)))
- (iter fields
- (fun ((f <field>))
- (let ((val (as <value> (! get values f))))
- (when (! is-static f)
- (pack "static "))
- (pack (! name f)) (pack ": ")
- (pack `(:value ,(vm-demirror vm val)))
- (pack "\n"))))))))))
- (df inspector-content (content (state <inspector-state>))
- (map (fun (part)
- (mcase part
- ((':value val)
- `(:value ,(pprint-to-string val) ,(assign-index val state)))
- (x (to-string x))))
- content))
- (df assign-index (obj (state <inspector-state>) => <int>)
- (! add (@ parts state) obj)
- (1- (! size (@ parts state))))
- (df content-range (l start end)
- (let* ((len (length l)) (end (min len end)))
- (list (subseq l start end) len start end)))
- (df inspector-pop ((state <inspector-state>) vm)
- (cond ((<= 2 (len (@ stack state)))
- (let ((obj (cadr (@ stack state))))
- (set (@ stack state) (cddr (@ stack state)))
- (inspect-object obj state vm)))
- (#t 'nil)))
- ;;;; IO redirection
- (define-simple-class <swank-writer> (<java.io.Writer>)
- (q :: <queue> init: (<queue> (as <int> 100)))
- ((*init*) (invoke-special <java.io.Writer> (this) '*init*))
- ((write (buffer <char[]>) (from <int>) (to <int>)) :: <void>
- (synchronized (this)
- (assert (not (== q #!null)))
- (! put q `(write ,(<str> buffer from to)))))
- ((close) :: <void>
- (synchronized (this)
- (! put q 'close)
- (set! q #!null)))
- ((flush) :: <void>
- (synchronized (this)
- (assert (not (== q #!null)))
- (let ((ex (<exchanger>)))
- (! put q `(flush ,ex))
- (! exchange ex #!null)))))
- (df swank-writer ((in <chan>) (q <queue>))
- (! set-name (current-thread) "swank-redirect-thread")
- (let* ((out (as <chan> (recv in)))
- (builder (<builder>))
- (flush (fun ()
- (unless (zero? (! length builder))
- (send out `(forward (:write-string ,(<str> builder))))
- (set! builder:length 0)))) ; pure magic
- (closed #f))
- (while (not closed)
- (mcase (! poll q 200 <timeunit>:MILLISECONDS)
- ('#!null (flush))
- (('write s)
- (! append builder (as <str> s))
- (when (> (! length builder) 4000)
- (flush)))
- (('flush ex)
- (flush)
- (! exchange (as <exchanger> ex) #!null))
- ('close
- (set closed #t)
- (flush))))))
- (df make-swank-outport ((out <chan>))
- (let ((w (<swank-writer>)))
- (mlet ((in . _) (spawn/chan (fun (c) (swank-writer c (@ q w)))))
- (send in out))
- (<gnu.mapping.OutPort> w #t #t)))
- ;;;; Monitor
- (df vm-monitor ((c <chan>))
- (! set-name (current-thread) "swank-vm-monitor")
- (let ((vm (vm-attach)))
- (log-vm-props vm)
- ;;(enable-uncaught-exception-events vm)
- (mlet* (((ev . _) (spawn/chan/catch
- (fun (c)
- (let ((q (! eventQueue vm)))
- (while #t
- (send c `(vm-event ,(to-list (! remove q)))))))))
- (to-string (vm-to-string vm))
- (state (tab)))
- (send c `(publish-vm ,vm))
- (while #t
- (mcase (recv* (list c ev))
- ((_ . ('get-vm cc))
- (send cc vm))
- ((,c . ('debug-info thread from to id))
- (reply c (debug-info thread from to state) id))
- ((,c . ('throw-to-toplevel thread id))
- (set state (throw-to-toplevel thread id c state)))
- ((,c . ('thread-continue thread id))
- (set state (thread-continue thread id c state)))
- ((,c . ('frame-src-loc thread frame id))
- (reply c (frame-src-loc thread frame state) id))
- ((,c . ('frame-details thread frame id))
- (reply c (list (frame-locals thread frame state) '()) id))
- ((,c . ('disassemble-frame thread frame id))
- (reply c (disassemble-frame thread frame state) id))
- ((,c . ('thread-frames thread from to id))
- (reply c (thread-frames thread from to state) id))
- ((,c . ('list-threads id))
- (reply c (list-threads vm state) id))
- ((,c . ('debug-thread ref))
- (set state (debug-thread ref state c)))
- ((,c . ('debug-nth-thread n))
- (let ((t (nth (get state 'all-threads #f) n)))
- ;;(log "thread ~d : ~a\n" n t)
- (set state (debug-thread t state c))))
- ((,c . ('quit-thread-browser id))
- (reply c 't id)
- (set state (del state 'all-threads)))
- ((,ev . ('vm-event es))
- ;;(log "vm-events: len=~a\n" (len es))
- (for (((e <event>) (as <list> es)))
- (set state (process-vm-event e c state))))
- ((_ . ('get-exception from tid))
- (mlet ((_ _ es) (get state tid #f))
- (send from (let ((e (car es)))
- (typecase e
- (<exception-event> (! exception e))
- (<event> e))))))
- ((_ . ('get-local rc tid frame var))
- (send rc (frame-local-var tid frame var state)))
- )))))
- (df reply ((c <chan>) value id)
- (send c `(forward (:return (:ok ,value) ,id))))
- (df reply-abort ((c <chan>) id)
- (send c `(forward (:return (:abort) ,id))))
- (df process-vm-event ((e <event>) (c <chan>) state)
- (log "vm-event: ~s\n" e)
- (typecase e
- (<exception-event>
- (log "exception-location: ~s\n" (src-loc>str (! location e)))
- (log "exception-catch-location: ~s\n" (src-loc>str (! catch-location e)))
- (let ((l (! catch-location e)))
- (cond ((or (nul? l)
- ;; (member (! source-path l) '("gnu/expr/ModuleExp.java"))
- )
- (process-exception e c state))
- (#t
- (let* ((t (! thread e))
- (r (! request e))
- (ex (! exception e)))
- (unless (eq? *last-exception* ex)
- (set *last-exception* ex)
- (set *last-stacktrace* (copy-stack t)))
- (! resume t))
- state))))
- (<step-event>
- (let* ((r (! request e))
- (k (! get-property r 'continuation)))
- (! disable r)
- (log "k: ~s\n" k)
- (k e))
- state)))
- (df process-exception ((e <exception-event>) (c <chan>) state)
- (let* ((tref (! thread e))
- (tid (! uniqueID tref))
- (s (get state tid #f)))
- (mcase s
- ('#f
- ;; XXX redundant in debug-thread
- (let* ((level 1)
- (state (put state tid (list tref level (list e)))))
- (send c `(forward (:debug ,tid ,level
- ,@(debug-info tid 0 15 state))))
- (send c `(forward (:debug-activate ,tid ,level)))
- state))
- ((_ level exs)
- (send c `(forward (:debug-activate ,(! uniqueID tref) ,level)))
- (put state tid (list tref (1+ level) (cons e exs)))))))
- (define-simple-class <faked-frame> ()
- (loc :: <location>)
- (args)
- (names)
- (values :: <java.util.Map>)
- (self)
- ((*init* (loc <location>) args names (values <java.util.Map>) self)
- (set (@ loc (this)) loc)
- (set (@ args (this)) args)
- (set (@ names (this)) names)
- (set (@ values (this)) values)
- (set (@ self (this)) self))
- ((toString) :: <str>
- (format "#<ff ~a>" (src-loc>str loc))))
- (df copy-stack ((t <thread-ref>))
- (packing (pack)
- (iter (! frames t)
- (fun ((f <frame>))
- (let ((vars (ignore-errors (! visibleVariables f))))
- (pack (<faked-frame>
- (or (ignore-errors (! location f)) #!null)
- (ignore-errors (! getArgumentValues f))
- (or vars #!null)
- (or (and vars (ignore-errors (! get-values f vars)))
- #!null)
- (ignore-errors (! thisObject f)))))))))
- (define-simple-class <listener-abort> (<java.lang.Throwable>)
- ((abort) :: void
- (primitive-throw (this))
- #!void))
- (define-simple-class <break-event> (<com.sun.jdi.event.Event>)
- (thread :: <thread-ref>)
- ((*init* (thread :: <thread-ref>)) (set (@ thread (this)) thread))
- ((request) :: <com.sun.jdi.request.EventRequest> #!null)
- ((virtualMachine) :: <vm> (! virtualMachine thread)))
- (df log-vm-props ((vm <vm>))
- (letrec-syntax ((p (syntax-rules ()
- ((p name) (log "~s: ~s\n" 'name (! name vm)))))
- (p* (syntax-rules ()
- ((p* n ...) (seq (p n) ...)))))
- (p* canBeModified
- canRedefineClasses
- canAddMethod
- canUnrestrictedlyRedefineClasses
- canGetBytecodes
- canGetConstantPool
- canGetSyntheticAttribute
- canGetSourceDebugExtension
- canPopFrames
- canForceEarlyReturn
- canGetMethodReturnValues
- canGetInstanceInfo
- )))
- ;;;;; Debugger
- (df debug-thread ((tref <thread-ref>) state (c <chan>))
- (! suspend tref)
- (let* ((ev (<break-event> tref))
- (id (! uniqueID tref))
- (level 1)
- (state (put state id (list tref level (list ev)))))
- (send c `(forward (:debug ,id ,level ,@(debug-info id 0 10 state))))
- (send c `(forward (:debug-activate ,id ,level)))
- state))
- (df debug-info ((tid <int>) (from <int>) to state)
- (mlet ((thread-ref level evs) (get state tid #f))
- (let* ((tref (as <thread-ref> thread-ref))
- (vm (! virtualMachine tref))
- (ev (as <event> (car evs)))
- (ex (typecase ev
- (<exception-event> (! exception ev))
- (<break-event> (<java.lang.Exception> "Interrupt"))))
- (desc (typecase ex
- (<obj-ref>
- ;;(log "ex: ~a ~a\n" ex (vm-demirror vm ex))
- (! toString (vm-demirror vm ex)))
- (<java.lang.Exception> (! toString ex))))
- (type (format " [type ~a]"
- (typecase ex
- (<obj-ref> (! name (! referenceType ex)))
- (<object> (!! getName getClass ex)))))
- (bt (thread-frames tid from to state)))
- `((,desc ,type nil) (("quit" "terminate current thread")) ,bt ()))))
- (df thread-frames ((tid <int>) (from <int>) to state)
- (mlet ((thread level evs) (get state tid #f))
- (let* ((thread (as <thread-ref> thread))
- (fcount (! frameCount thread))
- (stacktrace (event-stacktrace (car evs)))
- (missing (cond ((zero? (len stacktrace)) 0)
- (#t (- (len stacktrace) fcount))))
- (fstart (max (- from missing) 0))
- (flen (max (- to from missing) 0))
- (frames (! frames thread fstart (min flen (- fcount fstart)))))
- (packing (pack)
- (let ((i from))
- (dotimes (_ (max (- missing from) 0))
- (pack (list i (format "~a" (stacktrace i))))
- (set i (1+ i)))
- (iter frames (fun ((f <frame>))
- (let ((s (frame-to-string f)))
- (pack (list i s))
- (set i (1+ i))))))))))
- (df event-stacktrace ((ev <event>))
- (typecase ev
- (<exception-event>
- (let ((r (! request ev))
- (vm (! virtualMachine ev)))
- (cond ((== (vm-demirror vm (! exception ev))
- (ignore-errors (vm-demirror vm *last-exception*)))
- *last-stacktrace*)
- (#t
- (! getStackTrace
- (as <throwable> (vm-demirror vm (! exception ev))))))))
- (<event> (<java.lang.StackTraceElement[]>))))
- (df frame-to-string ((f <frame>))
- (let ((loc (! location f))
- (vm (! virtualMachine f)))
- (format "~a (~a)" (!! name method loc)
- (call-with-abort
- (fun () (format "~{~a~^ ~}"
- (mapi (! getArgumentValues f)
- (fun (arg)
- (pprint-to-string
- (vm-demirror vm arg))))))))))
- (df frame-src-loc ((tid <int>) (n <int>) state)
- (try-catch
- (mlet* (((frame vm) (nth-frame tid n state))
- (vm (as <vm> vm)))
- (src-loc>elisp
- (typecase frame
- (<frame> (! location frame))
- (<faked-frame> (@ loc frame))
- (<java.lang.StackTraceElement>
- (let* ((classname (! getClassName frame))
- (classes (! classesByName vm classname))
- (t (as <ref-type> (1st classes))))
- (1st (! locationsOfLine t (! getLineNumber frame))))))))
- (ex <throwable>
- (let ((msg (! getMessage ex)))
- `(:error ,(if (== msg #!null)
- (! toString ex)
- msg))))))
- (df nth-frame ((tid <int>) (n <int>) state)
- (mlet ((tref level evs) (get state tid #f))
- (let* ((thread (as <thread-ref> tref))
- (fcount (! frameCount thread))
- (stacktrace (event-stacktrace (car evs)))
- (missing (cond ((zero? (len stacktrace)) 0)
- (#t (- (len stacktrace) fcount))))
- (vm (! virtualMachine thread))
- (frame (cond ((< n missing)
- (stacktrace n))
- (#t (! frame thread (- n missing))))))
- (list frame vm))))
- ;;;;; Locals
- (df frame-locals ((tid <int>) (n <int>) state)
- (mlet ((thread _ _) (get state tid #f))
- (let* ((thread (as <thread-ref> thread))
- (vm (! virtualMachine thread))
- (p (fun (x) (pprint-to-string
- (call-with-abort (fun () (vm-demirror vm x)))))))
- (map (fun (x)
- (mlet ((name value) x)
- (list ':name name ':value (p value) ':id 0)))
- (%frame-locals tid n state)))))
- (df frame-local-var ((tid <int>) (frame <int>) (var <int>) state => <mirror>)
- (cadr (nth (%frame-locals tid frame state) var)))
- (df %frame-locals ((tid <int>) (n <int>) state)
- (mlet ((frame _) (nth-frame tid n state))
- (typecase frame
- (<frame>
- (let* ((visible (try-catch (! visibleVariables frame)
- (ex <com.sun.jdi.AbsentInformationException>
- '())))
- (map (! getValues frame visible))
- (p (fun (x) x)))
- (packing (pack)
- (let ((self (ignore-errors (! thisObject frame))))
- (when self
- (pack (list "this" (p self)))))
- (iter (! entrySet map)
- (fun ((e <java.util.Map$Entry>))
- (let ((var (as <local-var> (! getKey e)))
- (val (as <value> (! getValue e))))
- (pack (list (! name var) (p val)))))))))
- (<faked-frame>
- (packing (pack)
- (when (@ self frame)
- (pack (list "this" (@ self frame))))
- (iter (! entrySet (@ values frame))
- (fun ((e <java.util.Map$Entry>))
- (let ((var (as <local-var> (! getKey e)))
- (val (as <value> (! getValue e))))
- (pack (list (! name var) val)))))))
- (<java.lang.StackTraceElement> '()))))
- (df disassemble-frame ((tid <int>) (frame <int>) state)
- (mlet ((frame _) (nth-frame tid frame state))
- (typecase frame
- (<java.lang.StackTraceElement> "<??>")
- (<frame>
- (let* ((l (! location frame))
- (m (! method l))
- (c (! declaringType l)))
- (disassemble m))))))
- ;;;;; Restarts
- (df throw-to-toplevel ((tid <int>) (id <int>) (c <chan>) state)
- (mlet ((tref level exc) (get state tid #f))
- (let* ((t (as <thread-ref> tref))
- (ev (car exc)))
- (typecase ev
- (<exception-event>
- (! resume t)
- (reply-abort c id)
- (do ((level level (1- level))
- (exc exc (cdr exc)))
- ((null? exc))
- (send c `(forward (:debug-return ,tid ,level nil))))
- (del state tid))
- (<break-event>
- ;; XXX race condition?
- (let ((vm (! virtualMachine t)))
- (reply-abort c id)
- (! stop t (vm-mirror vm (<listener-abort>)))
- (! interrupt t)
- (! resume t)
- (! interrupt t)
- (do ((level level (1- level))
- (exc exc (cdr exc)))
- ((null? exc))
- (send c `(forward (:debug-return ,tid ,level nil))))
- (del state tid)))))))
- (df thread-continue ((tid <int>) (id <int>) (c <chan>) state)
- (mlet ((tref level exc) (get state tid #f))
- (let* ((t (as <thread-ref> tref)))
- (! resume t))
- (reply-abort c id)
- (do ((level level (1- level))
- (exc exc (cdr exc)))
- ((null? exc))
- (send c `(forward (:debug-return ,tid ,level nil))))
- (del state tid)))
- (df thread-step ((t <thread-ref>) k)
- (let* ((vm (! virtual-machine t))
- (erm (! eventRequestManager vm))
- (<sr> <com.sun.jdi.request.StepRequest>)
- (req (! createStepRequest erm t <sr>:STEP_MIN <sr>:STEP_OVER)))
- (! setSuspendPolicy req (@ SUSPEND_EVENT_THREAD req))
- (! addCountFilter req 1)
- (! put-property req 'continuation k)
- (! enable req)))
- (df eval-in-thread ((t <thread-ref>) sexp
- #!optional (env :: <env> (<env>:current)))
- (let* ((vm (! virtualMachine t))
- (sc :: <class-ref>
- (1st (! classes-by-name vm "kawa.standard.Scheme")))
- (ev :: <meth-ref>
- (1st (! methods-by-name sc "eval"
- (cat "(Ljava/lang/Object;Lgnu/mapping/Environment;)"
- "Ljava/lang/Object;")))))
- (! invokeMethod sc t ev (list sexp env) sc:INVOKE_SINGLE_THREADED)))
- ;;;;; Threads
- (df list-threads (vm :: <vm> state)
- (let* ((threads (! allThreads vm)))
- (put state 'all-threads threads)
- (packing (pack)
- (iter threads (fun ((t <thread-ref>))
- (pack (list (! name t)
- (let ((s (thread-status t)))
- (if (! is-suspended t)
- (cat "SUSPENDED/" s)
- s))
- (! uniqueID t))))))))
- (df thread-status (t :: <thread-ref>)
- (let ((s (! status t)))
- (cond ((= s t:THREAD_STATUS_UNKNOWN) "UNKNOWN")
- ((= s t:THREAD_STATUS_ZOMBIE) "ZOMBIE")
- ((= s t:THREAD_STATUS_RUNNING) "RUNNING")
- ((= s t:THREAD_STATUS_SLEEPING) "SLEEPING")
- ((= s t:THREAD_STATUS_MONITOR) "MONITOR")
- ((= s t:THREAD_STATUS_WAIT) "WAIT")
- ((= s t:THREAD_STATUS_NOT_STARTED) "NOT_STARTED")
- (#t "<bug>"))))
- ;;;;; Bootstrap
- (df vm-attach (=> <vm>)
- (attach (getpid) 20))
- (df attach (pid timeout)
- (log "attaching: ~a ~a\n" pid timeout)
- (let* ((<ac> <com.sun.jdi.connect.AttachingConnector>)
- (<arg> <com.sun.jdi.connect.Connector$Argument>)
- (vmm (com.sun.jdi.Bootstrap:virtualMachineManager))
- (pa (as <ac>
- (or
- (find-if (! attaching-connectors vmm)
- (fun (x :: <ac>)
- (! equals (! name x) "com.sun.jdi.ProcessAttach"))
- #f)
- (error "ProcessAttach connector not found"))))
- (args (! default-arguments pa)))
- (! set-value (as <arg> (! get args (to-str "pid"))) pid)
- (when timeout
- (! set-value (as <arg> (! get args (to-str "timeout"))) timeout))
- (log "attaching2: ~a ~a\n" pa args)
- (! attach pa args)))
- (df getpid ()
- (let ((p (make-process (command-parse "echo $PPID") #!null)))
- (! waitFor p)
- (! read-line (<java.io.BufferedReader> (<in> (! get-input-stream p))))))
- (df enable-uncaught-exception-events ((vm <vm>))
- (let* ((erm (! eventRequestManager vm))
- (req (! createExceptionRequest erm #!null #f #t)))
- (! setSuspendPolicy req (@ SUSPEND_EVENT_THREAD req))
- (! addThreadFilter req (vm-mirror vm (current-thread)))
- (! enable req))
- (let* ((erm (! eventRequestManager vm))
- (req (! createExceptionRequest erm #!null #t #f)))
- (! setSuspendPolicy req (@ SUSPEND_EVENT_THREAD req))
- (! addThreadFilter req (vm-mirror vm (current-thread)))
- (! addClassExclusionFilter req "java.lang.ClassLoader")
- (! addClassExclusionFilter req "java.net.URLClassLoader")
- (! addClassExclusionFilter req "java.net.URLClassLoader$1")
- (! enable req))
- #!void
- )
- (df set-stacktrace-recording ((vm <vm>) (flag <boolean>))
- (for (((e <com.sun.jdi.request.ExceptionRequest>)
- (!! exceptionRequests eventRequestManager vm)))
- (when (! notify-caught e)
- (! setEnabled e flag))))
- ;; (set-stacktrace-recording *the-vm* #f)
- (df vm-to-string ((vm <vm>))
- (let* ((obj (as <ref-type> (1st (! classesByName vm "java.lang.Object"))))
- (met (as <meth-ref> (1st (! methodsByName obj "toString")))))
- (fun ((o <obj-ref>) (t <thread-ref>))
- (! value
- (as <str-ref>
- (! invokeMethod o t met '() o:INVOKE_SINGLE_THREADED))))))
- (define-simple-class <swank-global-variable> ()
- (var allocation: 'static))
- (define-variable *global-get-mirror* #!null)
- (define-variable *global-set-mirror* #!null)
- (define-variable *global-get-raw* #!null)
- (define-variable *global-set-raw* #!null)
- (df init-global-field ((vm <vm>))
- (when (nul? *global-get-mirror*)
- (set <swank-global-variable>:var #!null) ; prepare class
- (let* ((c (as <com.sun.jdi.ClassType>
- (1st (! classes-by-name vm "swank$Mnglobal$Mnvariable"))))
- (f (! fieldByName c "var")))
- (set *global-get-mirror* (fun () (! getValue c f)))
- (set *global-set-mirror* (fun ((v <obj-ref>)) (! setValue c f v))))
- (set *global-get-raw* (fun () <swank-global-variable>:var))
- (set *global-set-raw* (fun (x) (set <swank-global-variable>:var x)))))
- (df vm-mirror ((vm <vm>) obj)
- (synchronized vm
- (init-global-field vm)
- (*global-set-raw* obj)
- (*global-get-mirror*)))
- (df vm-demirror ((vm <vm>) (v <value>))
- (synchronized vm
- (if (== v #!null)
- #!null
- (typecase v
- (<obj-ref> (init-global-field vm)
- (*global-set-mirror* v)
- (*global-get-raw*))
- (<com.sun.jdi.IntegerValue> (! value v))
- (<com.sun.jdi.LongValue> (! value v))
- (<com.sun.jdi.CharValue> (! value v))
- (<com.sun.jdi.ByteValue> (! value v))
- (<com.sun.jdi.BooleanValue> (! value v))
- (<com.sun.jdi.ShortValue> (! value v))
- (<com.sun.jdi.FloatValue> (! value v))
- (<com.sun.jdi.DoubleValue> (! value v))))))
- (df vm-set-slot ((vm <vm>) (o <object>) (name <str>) value)
- (let* ((o (as <obj-ref> (vm-mirror vm o)))
- (t (! reference-type o))
- (f (! field-by-name t name)))
- (! set-value o f (vm-mirror vm value))))
- (define-simple-class <ucex-handler>
- (<java.lang.Thread$UncaughtExceptionHandler>)
- (f :: <gnu.mapping.Procedure>)
- ((*init* (f :: <gnu.mapping.Procedure>)) (set (@ f (this)) f))
- ((uncaughtException (t <thread>) (e <throwable>))
- :: <void>
- ;;(! println (java.lang.System:.err) (to-str "uhexc:::"))
- (! apply2 f t e)
- #!void))
- ;;;; Channels
- (df spawn (f)
- (let ((thread (<thread> (%%runnable f))))
- (! start thread)
- thread))
- (df %%runnable (f => <java.lang.Runnable>)
- ;;(<runnable> f)
- (<gnu.mapping.RunnableClosure> f)
- )
- #|
- (df %runnable (f => <java.lang.Runnable>)
- (<runnable>
- (fun ()
- (try-catch (f)
- (ex <throwable>
- (log "exception in thread ~s: ~s" (current-thread)
- ex)
- (! printStackTrace ex))))))
- |#
- (df chan ()
- (let ((lock (<object>))
- (im (<chan>))
- (ex (<chan>)))
- (set (@ lock im) lock)
- (set (@ lock ex) lock)
- (set (@ peer im) ex)
- (set (@ peer ex) im)
- (cons im ex)))
- (df immutable? (obj)
- (or (== obj #!null)
- (symbol? obj)
- (number? obj)
- (char? obj)
- (instance? obj <str>)
- (null? obj)))
- (df send ((c <chan>) value => <void>)
- (df pass (obj)
- (cond ((immutable? obj) obj)
- ((string? obj) (! to-string obj))
- ((pair? obj)
- (let loop ((r (list (pass (car obj))))
- (o (cdr obj)))
- (cond ((null? o) (reverse! r))
- ((pair? o) (loop (cons (pass (car o)) r) (cdr o)))
- (#t (append (reverse! r) (pass o))))))
- ((instance? obj <chan>)
- (let ((o :: <chan> obj))
- (assert (== (@ owner o) (current-thread)))
- (synchronized (@ lock c)
- (set (@ owner o) (@ owner (@ peer c))))
- o))
- ((or (instance? obj <env>)
- (instance? obj <mirror>))
- ;; those can be shared, for pragmatic reasons
- obj
- )
- (#t (error "can't send" obj (class-name-sans-package obj)))))
- ;;(log "send: ~s ~s -> ~s\n" value (@ owner c) (@ owner (@ peer c)))
- (assert (== (@ owner c) (current-thread)))
- ;;(log "lock: ~s send\n" (@ owner (@ peer c)))
- (synchronized (@ owner (@ peer c))
- (! put (@ queue (@ peer c)) (pass value))
- (! notify (@ owner (@ peer c))))
- ;;(log "unlock: ~s send\n" (@ owner (@ peer c)))
- )
- (df recv ((c <chan>))
- (cdr (recv/timeout (list c) 0)))
- (df recv* ((cs <iterable>))
- (recv/timeout cs 0))
- (df recv/timeout ((cs <iterable>) (timeout <long>))
- (let ((self (current-thread))
- (end (if (zero? timeout)
- 0
- (+ (current-time) timeout))))
- ;;(log "lock: ~s recv\n" self)
- (synchronized self
- (let loop ()
- ;;(log "receive-loop: ~s\n" self)
- (let ((ready (find-if cs
- (fun ((c <chan>))
- (not (! is-empty (@ queue c))))
- #f)))
- (cond (ready
- ;;(log "unlock: ~s recv\n" self)
- (cons ready (! take (@ queue (as <chan> ready)))))
- ((zero? timeout)
- ;;(log "wait: ~s recv\n" self)
- (! wait self) (loop))
- (#t
- (let ((now (current-time)))
- (cond ((<= end now)
- 'timeout)
- (#t
- ;;(log "wait: ~s recv\n" self)
- (! wait self (- end now))
- (loop)))))))))))
- (df rpc ((c <chan>) msg)
- (mlet* (((im . ex) (chan))
- ((op . args) msg))
- (send c `(,op ,ex . ,args))
- (recv im)))
- (df spawn/chan (f)
- (mlet ((im . ex) (chan))
- (let ((thread (<thread> (%%runnable (fun () (f ex))))))
- (set (@ owner ex) thread)
- (! start thread)
- (cons im thread))))
- (df spawn/chan/catch (f)
- (spawn/chan
- (fun (c)
- (try-catch
- (f c)
- (ex <throwable>
- (send c `(error ,(! toString ex)
- ,(class-name-sans-package ex)
- ,(map (fun (e) (! to-string e))
- (array-to-list (! get-stack-trace ex))))))))))
- #|
- (define-simple-class <runnable> (<gnu.mapping.RunnableClosure>)
- (f :: <gnu.mapping.Procedure>)
- ((*init* (f <gnu.mapping.Procedure>))
- (invoke-special <gnu.mapping.RunnableClosure> (this) '*init* f)
- (set (@ f (this)) f))
- ((run) :: void
- (! set-environment-raw (<gnu.mapping.CallContext>:getInstance)
- (@ environment (this)))
- (! apply0 f)))
- |#
- ;;;; Logging
- (define swank-log-port (current-error-port))
- (df log (fstr #!rest args)
- (synchronized swank-log-port
- (apply format swank-log-port fstr args)
- (force-output swank-log-port))
- #!void)
- ;;;; Random helpers
- (df 1+ (x) (+ x 1))
- (df 1- (x) (- x 1))
- (df len (x => <int>)
- (typecase x
- (<list> (length x))
- (<str> (! length x))
- (<string> (string-length x))
- (<vector> (vector-length x))
- (<java.util.List> (! size x))
- (<object[]> (@ length x))))
- (df put (tab key value) (hash-table-set! tab key value) tab)
- (df get (tab key default) (hash-table-ref/default tab key default))
- (df del (tab key) (hash-table-delete! tab key) tab)
- (df tab () (make-hash-table))
- (df equal (x y => <boolean>) (equal? x y))
- (df current-thread (=> <thread>) (java.lang.Thread:currentThread))
- (df current-time (=> <long>) (java.lang.System:currentTimeMillis))
- (df nul? (x) (== x #!null))
- (df read-from-string (str)
- (call-with-input-string str read))
- ;;(df print-to-string (obj) (call-with-output-string (fun (p) (write obj p))))
-
- (df pprint-to-string (obj)
- (let* ((w (<java.io.StringWriter>))
- (p (<gnu.mapping.OutPort> w #t #f)))
- (try-catch (write obj p)
- (ex <throwable>
- (format p "#<error while printing ~a ~a>"
- ex (class-name-sans-package ex))))
- (! flush p)
- (to-string (! getBuffer w))))
- (define cat string-append)
- (df values-to-list (values)
- (typecase values
- (<gnu.mapping.Values> (array-to-list (! getValues values)))
- (<object> (list values))))
- ;; (to-list (as-list (values 1 2 2)))
- (df array-to-list ((array <object[]>) => <list>)
- (packing (pack)
- (dotimes (i (@ length array))
- (pack (array i)))))
- (df lisp-bool (obj)
- (cond ((== obj 'nil) #f)
- ((== obj 't) #t)
- (#t (error "Can't map lisp boolean" obj))))
- (df path-sans-extension ((p path) => <string>)
- (let ((ex (! get-extension p))
- (str (! to-string p)))
- (to-string (cond ((not ex) str)
- (#t (! substring str 0 (- (len str) (len ex) 1)))))))
- (df class-name-sans-package ((obj <object>))
- (cond ((nul? obj) "<#!null>")
- (#t
- (let* ((c (! get-class obj)) (n (! get-simple-name c)))
- (cond ((equal n "") (! get-name c))
- (#t n))))))
- (df list-env (#!optional (env :: <env> (<env>:current)))
- (let ((enum (! enumerateAllLocations env)))
- (packing (pack)
- (while (! hasMoreElements enum)
- (pack (! nextLocation enum))))))
- (df list-file (filename)
- (with (port (call-with-input-file filename))
- (let* ((lang (gnu.expr.Language:getDefaultLanguage))
- (messages (<gnu.text.SourceMessages>))
- (comp (! parse lang (as <gnu.mapping.InPort> port) messages 0)))
- (! get-module comp))))
- (df list-decls (file)
- (let* ((module (as <gnu.expr.ModuleExp> (list-file file))))
- (do ((decl :: <gnu.expr.Declaration>
- (! firstDecl module) (! nextDecl decl)))
- ((nul? decl))
- (format #t "~a ~a:~d:~d\n" decl
- (! getFileName decl)
- (! getLineNumber decl)
- (! getColumnNumber decl)
- ))))
- (df %time (f)
- (define-alias <mf> <java.lang.management.ManagementFactory>)
- (define-alias <gc> <java.lang.management.GarbageCollectorMXBean>)
- (let* ((gcs (<mf>:getGarbageCollectorMXBeans))
- (mem (<mf>:getMemoryMXBean))
- (jit (<mf>:getCompilationMXBean))
- (oldjit (! getTotalCompilationTime jit))
- (oldgc (packing (pack)
- (iter gcs (fun ((gc <gc>))
- (pack (cons gc
- (list (! getCollectionCount gc)
- (! getCollectionTime gc))))))))
- (heap (!! getUsed getHeapMemoryUsage mem))
- (nonheap (!! getUsed getNonHeapMemoryUsage mem))
- (start (java.lang.System:nanoTime))
- (values (f))
- (end (java.lang.System:nanoTime))
- (newheap (!! getUsed getHeapMemoryUsage mem))
- (newnonheap (!! getUsed getNonHeapMemoryUsage mem)))
- (format #t "~&")
- (let ((njit (! getTotalCompilationTime jit)))
- (format #t "; JIT compilation: ~:d ms (~:d)\n" (- njit oldjit) njit))
- (iter gcs (fun ((gc <gc>))
- (mlet ((_ count time) (assoc gc oldgc))
- (format #t "; GC ~a: ~:d ms (~d)\n"
- (! getName gc)
- (- (! getCollectionTime gc) time)
- (- (! getCollectionCount gc) count)))))
- (format #t "; Heap: ~@:d (~:d)\n" (- newheap heap) newheap)
- (format #t "; Non-Heap: ~@:d (~:d)\n" (- newnonheap nonheap) newnonheap)
- (format #t "; Elapsed time: ~:d us\n" (/ (- end start) 1000))
- values))
- (define-syntax time
- (syntax-rules ()
- ((time form)
- (%time (lambda () form)))))
- (df gc ()
- (let* ((mem (java.lang.management.ManagementFactory:getMemoryMXBean))
- (oheap (!! getUsed getHeapMemoryUsage mem))
- (onheap (!! getUsed getNonHeapMemoryUsage mem))
- (_ (! gc mem))
- (heap (!! getUsed getHeapMemoryUsage mem))
- (nheap (!! getUsed getNonHeapMemoryUsage mem)))
- (format #t "; heap: ~@:d (~:d) non-heap: ~@:d (~:d)\n"
- (- heap oheap) heap (- onheap nheap) nheap)))
- (df room ()
- (let* ((pools (java.lang.management.ManagementFactory:getMemoryPoolMXBeans))
- (mem (java.lang.management.ManagementFactory:getMemoryMXBean))
- (heap (!! getUsed getHeapMemoryUsage mem))
- (nheap (!! getUsed getNonHeapMemoryUsage mem)))
- (iter pools (fun ((p <java.lang.management.MemoryPoolMXBean>))
- (format #t "~&; ~a~1,16t: ~10:d\n"
- (! getName p)
- (!! getUsed getUsage p))))
- (format #t "; Heap~1,16t: ~10:d\n" heap)
- (format #t "; Non-Heap~1,16t: ~10:d\n" nheap)))
- ;; (df javap (class #!key method signature)
- ;; (let* ((<is> <java.io.ByteArrayInputStream>)
- ;; (bytes
- ;; (typecase class
- ;; (<string> (read-bytes (<java.io.FileInputStream> (to-str class))))
- ;; (<byte[]> class)
- ;; (<symbol> (read-class-file class))))
- ;; (cdata (<sun.tools.javap.ClassData> (<is> bytes)))
- ;; (p (<sun.tools.javap.JavapPrinter>
- ;; (<is> bytes)
- ;; (current-output-port)
- ;; (<sun.tools.javap.JavapEnvironment>))))
- ;; (cond (method
- ;; (dolist ((m <sun.tools.javap.MethodData>)
- ;; (array-to-list (! getMethods cdata)))
- ;; (when (and (equal (to-str method) (! getName m))
- ;; (or (not signature)
- ;; (equal signature (! getInternalSig m))))
- ;; (! printMethodSignature p m (! getAccess m))
- ;; (! printExceptions p m)
- ;; (newline)
- ;; (! printVerboseHeader p m)
- ;; (! printcodeSequence p m))))
- ;; (#t (p:print)))
- ;; (values)))
- (df read-bytes ((is <java.io.InputStream>) => <byte[]>)
- (let ((os (<java.io.ByteArrayOutputStream>)))
- (let loop ()
- (let ((c (! read is)))
- (cond ((= c -1))
- (#t (! write os c) (loop)))))
- (! to-byte-array os)))
- (df read-class-file ((name <symbol>) => <byte[]>)
- (let ((f (cat (! replace (to-str name) (as <char> #\.) (as <char> #\/))
- ".class")))
- (mcase (find-file-in-path f (class-path))
- ('#f (ferror "Can't find classfile for ~s" name))
- ((:zip zipfile entry)
- (let* ((z (<java.util.zip.ZipFile> (as <str> zipfile)))
- (e (z:getEntry (as <str> entry))))
- (read-bytes (z:getInputStream e))))
- ((:file s) (read-bytes (<java.io.FileInputStream> (as <str> s)))))))
- (df all-instances ((vm <vm>) (classname <str>))
- (mappend (fun ((c <class-ref>)) (to-list (! instances c 9999)))
- (%all-subclasses vm classname)))
- (df %all-subclasses ((vm <vm>) (classname <str>))
- (mappend (fun ((c <class-ref>)) (cons c (to-list (! subclasses c))))
- (to-list (! classes-by-name vm classname))))
- (df with-output-to-string (thunk => <str>)
- (call-with-output-string
- (fun (s) (parameterize ((current-output-port s)) (thunk)))))
- (df find-if ((i <iterable>) test default)
- (let ((iter (! iterator i))
- (found #f))
- (while (and (not found) (! has-next iter))
- (let ((e (! next iter)))
- (when (test e)
- (set found #t)
- (set default e))))
- default))
- (df filter ((i <iterable>) test => <list>)
- (packing (pack)
- (for ((e i))
- (when (test e)
- (pack e)))))
- (df iter ((i <iterable>) f)
- (for ((e i)) (f e)))
- (df mapi ((i <iterable>) f => <list>)
- (packing (pack) (for ((e i)) (pack (f e)))))
- (df nth ((i <iterable>) (n <int>))
- (let ((iter (! iterator i)))
- (dotimes (i n)
- (! next iter))
- (! next iter)))
- (df 1st ((i <iterable>)) (!! next iterator i))
- (df to-list ((i <iterable>) => <list>)
- (packing (pack) (for ((e i)) (pack e))))
- (df as-list ((o <java.lang.Object[]>) => <java.util.List>)
- (java.util.Arrays:asList o))
- (df mappend (f list)
- (apply append (map f list)))
- (df subseq (s from to)
- (typecase s
- (<list> (apply list (! sub-list s from to)))
- (<vector> (apply vector (! sub-list s from to)))
- (<str> (! substring s from to))
- (<byte[]> (let* ((len (as <int> (- to from)))
- (t (<byte[]> length: len)))
- (java.lang.System:arraycopy s from t 0 len)
- t))))
- (df to-string (obj => <string>)
- (cond ((instance? obj <str>) (<gnu.lists.FString> (as <str> obj)))
- ((string? obj) obj)
- ((symbol? obj) (symbol->string obj))
- ((instance? obj <java.lang.StringBuffer>)
- (<gnu.lists.FString> (as <java.lang.StringBuffer> obj)))
- ((instance? obj <java.lang.StringBuilder>)
- (<gnu.lists.FString> (as <java.lang.StringBuilder> obj)))
- (#t (error "Not a string designator" obj
- (class-name-sans-package obj)))))
- (df to-str (obj => <str>)
- (cond ((instance? obj <str>) obj)
- ((string? obj) (! toString obj))
- ((symbol? obj) (! getName (as <gnu.mapping.Symbol> obj)))
- (#t (error "Not a string designator" obj
- (class-name-sans-package obj)))))
- ;; Local Variables:
- ;; mode: goo
- ;; compile-command:"kawa -e '(compile-file \"swank-kawa.scm\"\"swank-kawa.zip\")'"
- ;; End: