1 /**************************************************************************/
2 /* */
3 /* OCaml */
4 /* */
5 /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
6 /* */
7 /* Copyright 1996 Institut National de Recherche en Informatique et */
8 /* en Automatique. */
9 /* */
10 /* All rights reserved. This file is distributed under the terms of */
11 /* the GNU Lesser General Public License version 2.1, with the */
12 /* special exception on linking described in the file LICENSE. */
13 /* */
14 /**************************************************************************/
15
16 #define CAML_INTERNALS
17
18 /* Interface with the byte-code debugger */
19
20 #ifdef _WIN32
21 #include <io.h>
22 #endif /* _WIN32 */
23
24 #include <string.h>
25
26 #include "caml/alloc.h"
27 #include "caml/config.h"
28 #include "caml/debugger.h"
29 #include "caml/misc.h"
30 #include "caml/osdeps.h"
31
32 int caml_debugger_in_use = 0;
33 uintnat caml_event_count;
34 int caml_debugger_fork_mode = 1; /* parent by default */
35
36 #if !defined(HAS_SOCKETS) || defined(NATIVE_CODE)
37
caml_debugger_init(void)38 void caml_debugger_init(void)
39 {
40 }
41
caml_debugger(enum event_kind event)42 void caml_debugger(enum event_kind event)
43 {
44 }
45
caml_debugger_cleanup_fork(void)46 void caml_debugger_cleanup_fork(void)
47 {
48 }
49
50 #else
51
52 #ifdef HAS_UNISTD
53 #include <unistd.h>
54 #endif
55 #include <errno.h>
56 #include <sys/types.h>
57 #ifndef _WIN32
58 #include <sys/wait.h>
59 #include <sys/socket.h>
60 #include <sys/un.h>
61 #include <netinet/in.h>
62 #include <arpa/inet.h>
63 #include <netdb.h>
64 #else
65 #define ATOM ATOM_WS
66 #include <winsock.h>
67 #undef ATOM
68 #include <process.h>
69 #endif
70
71 #include "caml/fail.h"
72 #include "caml/fix_code.h"
73 #include "caml/instruct.h"
74 #include "caml/intext.h"
75 #include "caml/io.h"
76 #include "caml/mlvalues.h"
77 #include "caml/stacks.h"
78 #include "caml/sys.h"
79
80 static value marshal_flags = Val_emptylist;
81
82 static int sock_domain; /* Socket domain for the debugger */
83 static union { /* Socket address for the debugger */
84 struct sockaddr s_gen;
85 #ifndef _WIN32
86 struct sockaddr_un s_unix;
87 #endif
88 struct sockaddr_in s_inet;
89 } sock_addr;
90 static int sock_addr_len; /* Length of sock_addr */
91
92 static int dbg_socket = -1; /* The socket connected to the debugger */
93 static struct channel * dbg_in; /* Input channel on the socket */
94 static struct channel * dbg_out;/* Output channel on the socket */
95
96 static char *dbg_addr = "(none)";
97
open_connection(void)98 static void open_connection(void)
99 {
100 #ifdef _WIN32
101 /* Set socket to synchronous mode so that file descriptor-oriented
102 functions (read()/write() etc.) can be used */
103
104 int oldvalue, oldvaluelen, newvalue, retcode;
105 oldvaluelen = sizeof(oldvalue);
106 retcode = getsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE,
107 (char *) &oldvalue, &oldvaluelen);
108 if (retcode == 0) {
109 newvalue = SO_SYNCHRONOUS_NONALERT;
110 setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE,
111 (char *) &newvalue, sizeof(newvalue));
112 }
113 #endif
114 dbg_socket = socket(sock_domain, SOCK_STREAM, 0);
115 #ifdef _WIN32
116 if (retcode == 0) {
117 /* Restore initial mode */
118 setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE,
119 (char *) &oldvalue, oldvaluelen);
120 }
121 #endif
122 if (dbg_socket == -1 ||
123 connect(dbg_socket, &sock_addr.s_gen, sock_addr_len) == -1){
124 caml_fatal_error_arg2 ("cannot connect to debugger at %s\n", dbg_addr,
125 "error: %s\n", strerror (errno));
126 }
127 #ifdef _WIN32
128 dbg_socket = _open_osfhandle(dbg_socket, 0);
129 if (dbg_socket == -1)
130 caml_fatal_error("_open_osfhandle failed");
131 #endif
132 dbg_in = caml_open_descriptor_in(dbg_socket);
133 dbg_out = caml_open_descriptor_out(dbg_socket);
134 if (!caml_debugger_in_use) caml_putword(dbg_out, -1); /* first connection */
135 #ifdef _WIN32
136 caml_putword(dbg_out, _getpid());
137 #else
138 caml_putword(dbg_out, getpid());
139 #endif
140 caml_flush(dbg_out);
141 }
142
close_connection(void)143 static void close_connection(void)
144 {
145 caml_close_channel(dbg_in);
146 caml_close_channel(dbg_out);
147 dbg_socket = -1; /* was closed by caml_close_channel */
148 }
149
150 #ifdef _WIN32
winsock_startup(void)151 static void winsock_startup(void)
152 {
153 WSADATA wsaData;
154 int err = WSAStartup(MAKEWORD(2, 0), &wsaData);
155 if (err) caml_fatal_error("WSAStartup failed");
156 }
157
winsock_cleanup(void)158 static void winsock_cleanup(void)
159 {
160 WSACleanup();
161 }
162 #endif
163
caml_debugger_init(void)164 void caml_debugger_init(void)
165 {
166 char * address;
167 char * port, * p;
168 struct hostent * host;
169 int n;
170
171 caml_register_global_root(&marshal_flags);
172 marshal_flags = caml_alloc(2, Tag_cons);
173 Store_field(marshal_flags, 0, Val_int(1)); /* Marshal.Closures */
174 Store_field(marshal_flags, 1, Val_emptylist);
175
176 address = caml_secure_getenv("CAML_DEBUG_SOCKET");
177 if (address == NULL) return;
178 dbg_addr = address;
179
180 #ifdef _WIN32
181 winsock_startup();
182 (void)atexit(winsock_cleanup);
183 #endif
184 /* Parse the address */
185 port = NULL;
186 for (p = address; *p != 0; p++) {
187 if (*p == ':') { *p = 0; port = p+1; break; }
188 }
189 if (port == NULL) {
190 #ifndef _WIN32
191 /* Unix domain */
192 sock_domain = PF_UNIX;
193 sock_addr.s_unix.sun_family = AF_UNIX;
194 strncpy(sock_addr.s_unix.sun_path, address,
195 sizeof(sock_addr.s_unix.sun_path));
196 sock_addr_len =
197 ((char *)&(sock_addr.s_unix.sun_path) - (char *)&(sock_addr.s_unix))
198 + strlen(address);
199 #else
200 caml_fatal_error("Unix sockets not supported");
201 #endif
202 } else {
203 /* Internet domain */
204 sock_domain = PF_INET;
205 for (p = (char *) &sock_addr.s_inet, n = sizeof(sock_addr.s_inet);
206 n > 0; n--) *p++ = 0;
207 sock_addr.s_inet.sin_family = AF_INET;
208 sock_addr.s_inet.sin_addr.s_addr = inet_addr(address);
209 if (sock_addr.s_inet.sin_addr.s_addr == -1) {
210 host = gethostbyname(address);
211 if (host == NULL)
212 caml_fatal_error_arg("Unknown debugging host %s\n", address);
213 memmove(&sock_addr.s_inet.sin_addr, host->h_addr, host->h_length);
214 }
215 sock_addr.s_inet.sin_port = htons(atoi(port));
216 sock_addr_len = sizeof(sock_addr.s_inet);
217 }
218 open_connection();
219 caml_debugger_in_use = 1;
220 caml_trap_barrier = caml_stack_high;
221 }
222
getval(struct channel * chan)223 static value getval(struct channel *chan)
224 {
225 value res;
226 if (caml_really_getblock(chan, (char *) &res, sizeof(res)) < sizeof(res))
227 caml_raise_end_of_file(); /* Bad, but consistent with caml_getword */
228 return res;
229 }
230
putval(struct channel * chan,value val)231 static void putval(struct channel *chan, value val)
232 {
233 caml_really_putblock(chan, (char *) &val, sizeof(val));
234 }
235
safe_output_value(struct channel * chan,value val)236 static void safe_output_value(struct channel *chan, value val)
237 {
238 struct longjmp_buffer raise_buf, * saved_external_raise;
239
240 /* Catch exceptions raised by [caml_output_val] */
241 saved_external_raise = caml_external_raise;
242 if (sigsetjmp(raise_buf.buf, 0) == 0) {
243 caml_external_raise = &raise_buf;
244 caml_output_val(chan, val, marshal_flags);
245 } else {
246 /* Send wrong magic number, will cause [caml_input_value] to fail */
247 caml_really_putblock(chan, "\000\000\000\000", 4);
248 }
249 caml_external_raise = saved_external_raise;
250 }
251
252 #define Pc(sp) ((code_t)((sp)[0]))
253 #define Env(sp) ((sp)[1])
254 #define Extra_args(sp) (Long_val(((sp)[2])))
255 #define Locals(sp) ((sp) + 3)
256
caml_debugger(enum event_kind event)257 void caml_debugger(enum event_kind event)
258 {
259 value * frame;
260 intnat i, pos;
261 value val;
262
263 if (dbg_socket == -1) return; /* Not connected to a debugger. */
264
265 /* Reset current frame */
266 frame = caml_extern_sp + 1;
267
268 /* Report the event to the debugger */
269 switch(event) {
270 case PROGRAM_START: /* Nothing to report */
271 goto command_loop;
272 case EVENT_COUNT:
273 caml_putch(dbg_out, REP_EVENT);
274 break;
275 case BREAKPOINT:
276 caml_putch(dbg_out, REP_BREAKPOINT);
277 break;
278 case PROGRAM_EXIT:
279 caml_putch(dbg_out, REP_EXITED);
280 break;
281 case TRAP_BARRIER:
282 caml_putch(dbg_out, REP_TRAP);
283 break;
284 case UNCAUGHT_EXC:
285 caml_putch(dbg_out, REP_UNCAUGHT_EXC);
286 break;
287 }
288 caml_putword(dbg_out, caml_event_count);
289 if (event == EVENT_COUNT || event == BREAKPOINT) {
290 caml_putword(dbg_out, caml_stack_high - frame);
291 caml_putword(dbg_out, (Pc(frame) - caml_start_code) * sizeof(opcode_t));
292 } else {
293 /* No PC and no stack frame associated with other events */
294 caml_putword(dbg_out, 0);
295 caml_putword(dbg_out, 0);
296 }
297 caml_flush(dbg_out);
298
299 command_loop:
300
301 /* Read and execute the commands sent by the debugger */
302 while(1) {
303 switch(caml_getch(dbg_in)) {
304 case REQ_SET_EVENT:
305 pos = caml_getword(dbg_in);
306 Assert (pos >= 0);
307 Assert (pos < caml_code_size);
308 caml_set_instruction(caml_start_code + pos / sizeof(opcode_t), EVENT);
309 break;
310 case REQ_SET_BREAKPOINT:
311 pos = caml_getword(dbg_in);
312 Assert (pos >= 0);
313 Assert (pos < caml_code_size);
314 caml_set_instruction(caml_start_code + pos / sizeof(opcode_t), BREAK);
315 break;
316 case REQ_RESET_INSTR:
317 pos = caml_getword(dbg_in);
318 Assert (pos >= 0);
319 Assert (pos < caml_code_size);
320 pos = pos / sizeof(opcode_t);
321 caml_set_instruction(caml_start_code + pos, caml_saved_code[pos]);
322 break;
323 case REQ_CHECKPOINT:
324 #ifndef _WIN32
325 i = fork();
326 if (i == 0) {
327 close_connection(); /* Close parent connection. */
328 open_connection(); /* Open new connection with debugger */
329 } else {
330 caml_putword(dbg_out, i);
331 caml_flush(dbg_out);
332 }
333 #else
334 caml_fatal_error("error: REQ_CHECKPOINT command");
335 exit(-1);
336 #endif
337 break;
338 case REQ_GO:
339 caml_event_count = caml_getword(dbg_in);
340 return;
341 case REQ_STOP:
342 exit(0);
343 break;
344 case REQ_WAIT:
345 #ifndef _WIN32
346 wait(NULL);
347 #else
348 caml_fatal_error("Fatal error: REQ_WAIT command");
349 exit(-1);
350 #endif
351 break;
352 case REQ_INITIAL_FRAME:
353 frame = caml_extern_sp + 1;
354 /* Fall through */
355 case REQ_GET_FRAME:
356 caml_putword(dbg_out, caml_stack_high - frame);
357 if (frame < caml_stack_high){
358 caml_putword(dbg_out, (Pc(frame) - caml_start_code) * sizeof(opcode_t));
359 }else{
360 caml_putword (dbg_out, 0);
361 }
362 caml_flush(dbg_out);
363 break;
364 case REQ_SET_FRAME:
365 i = caml_getword(dbg_in);
366 frame = caml_stack_high - i;
367 break;
368 case REQ_UP_FRAME:
369 i = caml_getword(dbg_in);
370 if (frame + Extra_args(frame) + i + 3 >= caml_stack_high) {
371 caml_putword(dbg_out, -1);
372 } else {
373 frame += Extra_args(frame) + i + 3;
374 caml_putword(dbg_out, caml_stack_high - frame);
375 caml_putword(dbg_out, (Pc(frame) - caml_start_code) * sizeof(opcode_t));
376 }
377 caml_flush(dbg_out);
378 break;
379 case REQ_SET_TRAP_BARRIER:
380 i = caml_getword(dbg_in);
381 caml_trap_barrier = caml_stack_high - i;
382 break;
383 case REQ_GET_LOCAL:
384 i = caml_getword(dbg_in);
385 putval(dbg_out, Locals(frame)[i]);
386 caml_flush(dbg_out);
387 break;
388 case REQ_GET_ENVIRONMENT:
389 i = caml_getword(dbg_in);
390 putval(dbg_out, Field(Env(frame), i));
391 caml_flush(dbg_out);
392 break;
393 case REQ_GET_GLOBAL:
394 i = caml_getword(dbg_in);
395 putval(dbg_out, Field(caml_global_data, i));
396 caml_flush(dbg_out);
397 break;
398 case REQ_GET_ACCU:
399 putval(dbg_out, *caml_extern_sp);
400 caml_flush(dbg_out);
401 break;
402 case REQ_GET_HEADER:
403 val = getval(dbg_in);
404 caml_putword(dbg_out, Hd_val(val));
405 caml_flush(dbg_out);
406 break;
407 case REQ_GET_FIELD:
408 val = getval(dbg_in);
409 i = caml_getword(dbg_in);
410 if (Tag_val(val) != Double_array_tag) {
411 caml_putch(dbg_out, 0);
412 putval(dbg_out, Field(val, i));
413 } else {
414 double d = Double_field(val, i);
415 caml_putch(dbg_out, 1);
416 caml_really_putblock(dbg_out, (char *) &d, 8);
417 }
418 caml_flush(dbg_out);
419 break;
420 case REQ_MARSHAL_OBJ:
421 val = getval(dbg_in);
422 safe_output_value(dbg_out, val);
423 caml_flush(dbg_out);
424 break;
425 case REQ_GET_CLOSURE_CODE:
426 val = getval(dbg_in);
427 caml_putword(dbg_out, (Code_val(val)-caml_start_code) * sizeof(opcode_t));
428 caml_flush(dbg_out);
429 break;
430 case REQ_SET_FORK_MODE:
431 caml_debugger_fork_mode = caml_getword(dbg_in);
432 break;
433 }
434 }
435 }
436
caml_debugger_cleanup_fork(void)437 void caml_debugger_cleanup_fork(void)
438 {
439 /* We could remove all of the breakpoints, but closing the connection
440 * means that they'll just be skipped anyway. */
441 close_connection();
442 caml_debugger_in_use = 0;
443 }
444
445 #endif
446