67 |
"w")) |
"w")) |
68 |
;; Write initial context to debug server. |
;; Write initial context to debug server. |
69 |
(write-form (list 'name name (getpid))) |
(write-form (list 'name name (getpid))) |
70 |
(write-form (cons 'modules (map module-name (loaded-modules)))) |
;(write-form (cons 'modules (map module-name (loaded-modules)))) |
71 |
;; Start the asynchronous UI thread. |
;; Start the asynchronous UI thread. |
72 |
(start-async-gds-thread) |
(start-async-gds-thread) |
73 |
;; If `debug' is true, debug immediately. |
;; If `debug' is true, debug immediately. |
87 |
;; Start the asynchronous UI thread. |
;; Start the asynchronous UI thread. |
88 |
(begin-thread |
(begin-thread |
89 |
(set! async-gds-thread (current-thread)) |
(set! async-gds-thread (current-thread)) |
|
(lock-mutex mutex) |
|
90 |
;;(write (cons admin gds-port)) |
;;(write (cons admin gds-port)) |
91 |
;;(newline) |
;;(newline) |
92 |
|
(lock-mutex mutex) |
93 |
(catch 'server-died |
(catch 'server-died |
94 |
(lambda () |
(lambda () |
95 |
(let loop ((avail '())) |
(let loop ((avail '())) |
96 |
|
(write-note 'startloop) |
97 |
;;(write avail) |
;;(write avail) |
98 |
;;(newline) |
;;(newline) |
99 |
(cond ((not gds-port)) ; exit loop |
(cond ((not gds-port)) ; exit loop |
100 |
((null? avail) |
((null? avail) |
101 |
(write-status 'ready-for-input) |
(write-status 'ready-for-input) |
102 |
(loop (car (select (list gds-port (car admin)) |
(unlock-mutex mutex) |
103 |
'() '())))) |
(let ((ports (car (select (list gds-port (car admin)) |
104 |
|
'() '())))) |
105 |
|
(lock-mutex mutex) |
106 |
|
(loop ports))) |
107 |
(else |
(else |
108 |
|
(write-note 'sthg-to-read) |
109 |
(let ((port (car avail))) |
(let ((port (car avail))) |
110 |
(if (eq? port gds-port) |
(if (eq? port gds-port) |
111 |
(handle-instruction #f (read gds-port)) |
(handle-instruction #f (read gds-port)) |
112 |
(begin |
(begin |
113 |
|
(write-note 'debugger-takeover) |
114 |
;; Notification from debugger that it |
;; Notification from debugger that it |
115 |
;; wants to take over. Read the |
;; wants to take over. Read the |
116 |
;; notification char. |
;; notification char. |
117 |
(read-char (car admin)) |
(read-char (car admin)) |
118 |
;; Wait on condition variable - this allows the |
;; Wait on condition variable - this allows the |
119 |
;; debugger thread to grab the mutex. |
;; debugger thread to grab the mutex. |
120 |
(wait-condition-variable condition mutex))) |
(write-note 'cond-wait) |
121 |
|
(signal-condition-variable condition) |
122 |
|
(wait-condition-variable condition mutex) |
123 |
|
)) |
124 |
;; Loop. |
;; Loop. |
125 |
(loop (cdr avail))))))) |
(loop '())))) |
126 |
|
(write-note 'loopexited))) |
127 |
(lambda args #f)) |
(lambda args #f)) |
128 |
(set! gds-disable-async-thread noop) |
(set! gds-disable-async-thread noop) |
129 |
(set! gds-continue-async-thread noop) |
(set! gds-continue-async-thread noop) |
132 |
;; Redefine procs used by debugger thread to take control. |
;; Redefine procs used by debugger thread to take control. |
133 |
(set! gds-disable-async-thread |
(set! gds-disable-async-thread |
134 |
(lambda () |
(lambda () |
135 |
|
(lock-mutex mutex) |
136 |
(write-char #\x (cdr admin)) |
(write-char #\x (cdr admin)) |
137 |
(force-output (cdr admin)) |
(force-output (cdr admin)) |
138 |
|
(write-note 'char-written) |
139 |
|
(wait-condition-variable condition mutex) |
140 |
;;(display "gds-disable-async-thread: locking mutex...\n" |
;;(display "gds-disable-async-thread: locking mutex...\n" |
141 |
;; (current-error-port)) |
;; (current-error-port)) |
142 |
(lock-mutex mutex))) |
)) |
143 |
(set! gds-continue-async-thread |
(set! gds-continue-async-thread |
144 |
(lambda () |
(lambda () |
145 |
(unlock-mutex mutex) |
(write-note 'cond-signal) |
146 |
(signal-condition-variable condition))))) |
(signal-condition-variable condition) |
147 |
|
;; Make sure that the async thread has got the message |
148 |
|
;; before we could possibly try to grab the main mutex |
149 |
|
;; again. |
150 |
|
(unlock-mutex mutex))))) |
151 |
|
|
152 |
(define accumulated-output '()) |
(define accumulated-output '()) |
153 |
|
|
212 |
(newline gds-port) |
(newline gds-port) |
213 |
(force-output gds-port)) |
(force-output gds-port)) |
214 |
|
|
215 |
|
(define (write-note note) |
216 |
|
;; Write a note (for debugging this code) to UI frontend. |
217 |
|
(false-if-exception (write-form `(note ,note)))) |
218 |
|
|
219 |
(define (stack->emacs-readable stack) |
(define (stack->emacs-readable stack) |
220 |
;; Return Emacs-readable representation of STACK. |
;; Return Emacs-readable representation of STACK. |
221 |
(map (lambda (index) |
(map (lambda (index) |