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