comparison keiko/xmain.c @ 0:bfdcc3820b32

Basis
author Mike Spivey <mike@cs.ox.ac.uk>
date Thu, 05 Oct 2017 08:04:15 +0100
parents
children
comparison
equal deleted inserted replaced
-1:000000000000 0:bfdcc3820b32
1 /*
2 * xmain.c
3 *
4 * This file is part of the Oxford Oberon-2 compiler
5 * Copyright (c) 2006--2016 J. M. Spivey
6 * All rights reserved
7 *
8 * Redistribution and use in source and binary forms, with or without
9 * modification, are permitted provided that the following conditions are met:
10 *
11 * 1. Redistributions of source code must retain the above copyright notice,
12 * this list of conditions and the following disclaimer.
13 * 2. Redistributions in binary form must reproduce the above copyright notice,
14 * this list of conditions and the following disclaimer in the documentation
15 * and/or other materials provided with the distribution.
16 * 3. The name of the author may not be used to endorse or promote products
17 * derived from this software without specific prior written permission.
18 *
19 * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
20 * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
21 * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
22 * IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
23 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
24 * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
25 * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
26 * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
27 * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
28 * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
29 */
30
31 #define EXTERN
32 #include "obx.h"
33 #include "keiko.h"
34 #include "exec.h"
35
36 #ifdef JIT
37 #include "vm.h"
38 #ifdef DEBUG
39 #define JTEST 1
40 #endif
41 #endif
42
43 #ifdef PROFILE
44 #define MYNAME "profiler"
45 #else
46 #ifdef OBXDEB
47 #define MYNAME "debugging monitor"
48 #else
49 #define MYNAME "runtime system"
50 #endif
51 #endif
52
53 const char *version =
54 "Oxford Oberon-2 " MYNAME " version " PACKAGE_VERSION " [build " REVID "]"
55 #ifdef JIT
56 " (JIT)"
57 #else
58 ""
59 #endif
60 #ifdef DEBUG
61 " (debug)"
62 #else
63 ""
64 #endif
65 ;
66 const char *copyright = "Copyright (C) 1999--2012 J. M. Spivey";
67
68 extern int vm_debug;
69
70 /* Helper functions for the loader */
71
72 module make_module(char *name, uchar *addr, int chksum, int nlines) {
73 module m = (module) scratch_alloc(sizeof(struct _module));
74 m->m_name = name;
75 m->m_addr = addr;
76 #ifdef PROFILE
77 m->m_nlines = nlines;
78 m->m_lcount = NULL;
79 if (lflag && nlines > 0) {
80 m->m_lcount =
81 (unsigned *) scratch_alloc(nlines * sizeof(unsigned));
82 memset(m->m_lcount, 0, nlines * sizeof(int));
83 }
84 #endif
85 #ifdef OBXDEB
86 debug_message("module %s %#x", name, chksum);
87 #endif
88 return m;
89 }
90
91 proc make_proc(char *name, uchar *addr) {
92 proc p = (proc) scratch_alloc(sizeof(struct _proc));
93 p->p_name = name;
94 p->p_addr = (value *) addr;
95 #ifdef PROFILE
96 p->p_calls = p->p_rec = p->p_self = p->p_child = 0;
97 p->p_parents = p->p_children = NULL;
98 #endif
99 #ifdef OBXDEB
100 debug_message("proc %s %#x %#x %d", name, address(addr),
101 p->p_addr[CP_CODE].a, p->p_addr[CP_SIZE].i);
102 #endif
103 return p;
104 }
105
106 void make_symbol(const char *kind, char *name, uchar *addr) {
107 #ifdef OBXDEB
108 debug_message("%s %s %#x", kind, name, address(addr));
109 #endif
110 }
111
112 /* Runtime errors */
113
114 #ifndef OBXDEB
115 #define TOP 5 /* Number of frames shown at top and bottom */
116 #define BOT 5
117 #define GAP 10 /* Don't omit less than this many frames */
118 #define NBUF (BOT+GAP-1)
119
120 static void backtrace(value *bp) {
121 value *fp = bp, *cp = valptr(bp[CP]);
122 proc p = find_proc(cp);
123 int n, j;
124 proc fbuf[NBUF];
125
126 fprintf(stderr, "In procedure %s\n", p->p_name);
127
128 /* Chain down the stack, printing the first TOP frames,
129 and saving the last NBUF in a circular buffer. */
130 for (n = 0;; n++) {
131 /* Each frame contains the cp and bp of its caller */
132 fp = valptr(fp[BP]); /* Base pointer of next frame */
133 if (fp == NULL) break;
134 cp = valptr(fp[CP]); /* Constant pool of next frame */
135 fbuf[n%NBUF] = p = find_proc(cp);
136 if (n < TOP)
137 fprintf(stderr, " called from %s\n", p->p_name);
138 }
139
140 /* Now the last NBUF frames are f(n-NBUF), ..., f(n-1)
141 where f(i) = fbuf[i%NBUF] -- unless there are fewer
142 then NBUF frames in all. */
143
144 if (n < TOP+GAP+BOT)
145 /* Print the n-TOP frames not printed already */
146 j = TOP;
147 else {
148 /* Omit n-(TOP+BOT) frames (at least GAP) and print the
149 last BOT frames */
150 fprintf(stderr, " ... %d intervening frames omitted ...\n",
151 n-(TOP+BOT));
152 j = n-BOT;
153 }
154
155 /* Print frames j, ..., n-1 */
156 for (; j < n; j++)
157 fprintf(stderr, " called from %s\n", fbuf[j%NBUF]->p_name);
158 }
159 #endif
160
161 static const char *message(int code) {
162 switch (code) {
163 case E_CAST:
164 return "dynamic type error in cast";
165 case E_ASSIGN:
166 return "dynamic type error in record assignment";
167 case E_CASE:
168 return "no matching label in CASE statement";
169 case E_WITH:
170 return "no matching type guard in WITH statement";
171 case E_ASSERT:
172 return "assertion failed (%d)";
173 case E_RETURN:
174 return "function failed to return a result";
175 case E_BOUND:
176 return "array bound error";
177 case E_NULL:
178 return "null pointer error";
179 case E_DIV:
180 return "DIV or MOD by zero";
181 case E_FDIV:
182 return "division by zero";
183 case E_STACK:
184 return "stack overflow";
185 case E_GLOB:
186 return "assignment of local procedure";
187 default:
188 return "the impossible has happened";
189 }
190 }
191
192 /* error_stop -- runtime error with explicit message text */
193 void error_stop(const char *msg, int line, value *bp, uchar *pc) {
194 value *cp = valptr(bp[CP]);
195
196 #ifdef OBXDEB
197 char buf[256];
198 sprintf(buf, msg, ob_res.i);
199 debug_break(cp, bp, pc, "error %d %s", line, buf);
200 #else
201 module mod = find_module(cp);
202
203 fprintf(stderr, "Runtime error: ");
204 fprintf(stderr, msg, ob_res.i);
205 if (line > 0) fprintf(stderr, " on line %d", line);
206 if (mod != NULL && strcmp(mod->m_name, "_Builtin") != 0)
207 fprintf(stderr, " in module %s", mod->m_name);
208 fprintf(stderr, "\n");
209 fflush(stderr);
210
211 if (nprocs == 0)
212 fprintf(stderr, "(No debugging information available)\n");
213 else if (bp != NULL)
214 backtrace(bp);
215
216 fflush(stderr);
217 #endif
218
219 exit(2);
220 }
221
222 /* runtime_error -- report a runtime error */
223 void runtime_error(int m, int line, value *bp, uchar *pc) {
224 error_stop(message(m), line, bp, pc);
225 }
226
227 /* rterror -- simple version of runtime_error for JIT */
228 void rterror(int num, int line, value *bp) {
229 runtime_error(num, line, bp, NULL);
230 }
231
232 /* stkoflo -- stack overflow handler for JIT */
233 void stkoflo(value *bp) {
234 runtime_error(E_STACK, 0, bp, NULL);
235 }
236
237
238 /* Startup */
239
240 static void run(value *prog) {
241 value *sp;
242
243 /* Allow 32-word safety margin (for tracing) */
244 sp = (value *) (stack + stack_size) - 32;
245
246 sp -= HEAD;
247 sp[BP].a = address(NULL);
248 sp[PC].a = address(NULL);
249 sp[CP].a = address(prog);
250 primcall(prog, sp);
251 }
252
253 mybool custom_file(char *name) {
254 char buf[4];
255 FILE *fp;
256 int nread;
257 mybool result;
258
259 fp = fopen(name, "rb");
260 if (fp == NULL) return FALSE;
261 fseek(fp, - (long) sizeof(trailer), SEEK_END);
262 nread = fread(buf, 1, 4, fp);
263 if (nread < 4 || strncmp(buf, MAGIC, 4) != 0)
264 result = FALSE;
265 else {
266 fseek(fp, 0, SEEK_SET);
267 nread = fread(buf, 1, 2, fp);
268 result = (nread == 2 && strncmp(buf, "#!", 2) != 0);
269 }
270 fclose(fp);
271 return result;
272 }
273
274 #ifdef WINDOWS
275 #include <windows.h>
276 #include <winbase.h>
277
278 char *search_path(char *name) {
279 static char buf[_MAX_PATH];
280 char *filepart;
281
282 if (SearchPath(NULL, name, ".exe", _MAX_PATH, buf, &filepart) == 0)
283 return NULL;
284
285 return buf;
286 }
287 #else
288 #include <sys/stat.h>
289 #ifdef HAVE_UNISTD_H
290 #include <unistd.h>
291 #endif
292
293 char *search_path(char *name) {
294 char *path;
295 static char buf[256];
296 struct stat stbuf;
297
298 if (name == NULL || strchr(name, '/') != NULL) return name;
299
300 path = getenv("PATH");
301 if (path == NULL) return NULL;
302
303 for (char *p = path, *q; p != NULL; p = q) {
304 q = strchr(p, ':');
305 char *r;
306 if (q == NULL) {
307 strcpy(buf, p);
308 r = buf + strlen(p);
309 } else {
310 strncpy(buf, p, q-p);
311 r = buf + (q-p); q++;
312 }
313 if (r > buf) *r++ = '/';
314 strcpy(r, name);
315
316 if (access(buf, R_OK) == 0 && stat(buf, &stbuf) == 0
317 && S_ISREG(stbuf.st_mode))
318 return buf;
319 }
320
321 return NULL;
322 }
323 #endif
324
325 #define argc saved_argc
326 #define argv saved_argv
327
328 static char *progname;
329 #ifdef PROFILE
330 static char *profout;
331 static const char *dumpname = "obprof.out";
332 #endif
333
334 static void usage(void) {
335 #ifdef PROFILE
336 fprintf(stderr,
337 "Usage: %s [-g] [-pl] [-o file] program [arg ...]\n",
338 progname);
339 #else
340 fprintf(stderr, "Usage: %s program [arg ...]\n", progname);
341 #endif
342 fflush(stderr);
343 _exit(1);
344 }
345
346 #ifdef JTEST
347 static mybool tflag = 0;
348 #endif
349
350 /* read_flags -- interpret flags */
351 static void read_flags(void) {
352 for (;;) {
353 argc--; argv++;
354 if (argc == 0 || argv[0][0] != '-') return;
355
356 if (strcmp(argv[0], "--") == 0) {
357 argc--; argv++;
358 return;
359 } else if (strcmp(argv[0], "-d") == 0) {
360 dflag++;
361 } else if (strcmp(argv[0], "-v") == 0) {
362 fprintf(stderr, "%s\n", version);
363 exit(0);
364 }
365 #ifdef PROFILE
366 else if (argc >= 2 && strcmp(argv[0], "-o") == 0) {
367 profout = argv[1];
368 argc--; argv++;
369 } else if (strcmp(argv[0], "-g") == 0) {
370 gflag = TRUE;
371 } else if (strcmp(argv[0], "-l") == 0
372 || strcmp(argv[0], "-pl") == 0) {
373 lflag = TRUE;
374 }
375 #endif
376 #ifdef TRACE
377 else if (strcmp(argv[0], "-q") == 0) {
378 qflag++;
379 }
380 #endif
381 #ifdef OBXDEB
382 else if (argc >= 2 && strcmp(argv[0], "-p") == 0) {
383 debug_socket = argv[1];
384 argc--; argv++;
385 }
386 #endif
387 #ifdef JTEST
388 else if (strcmp(argv[0], "-t") == 0) {
389 tflag++;
390 }
391 #endif
392 else {
393 usage();
394 }
395 }
396 }
397
398 #ifdef PROFILE
399 static void dump_lcounts(void) {
400 FILE *fp = fopen(dumpname, "w");
401 if (fp == NULL) {
402 fprintf(stderr, "%s: cannot write\n", dumpname);
403 exit(1);
404 }
405
406 for (int m = 0; m < nmods; m++)
407 for (int n = 1; n <= modtab[m]->m_nlines; n++)
408 if (modtab[m]->m_lcount[n-1] > 0)
409 fprintf(fp, "%s %d %u\n", modtab[m]->m_name, n,
410 modtab[m]->m_lcount[n-1]);
411
412 fclose(fp);
413 }
414
415 static void print_profile(void) {
416 FILE *fp = stderr;
417
418 if (profout != NULL) {
419 fp = fopen(profout, "w");
420 if (fp == NULL) {
421 fprintf(stderr, "%s: cannot write\n", profout);
422 exit(1);
423 }
424
425 fprintf(fp, "Command line:\n\n");
426 fprintf(fp, " %s", saved_argv[0]);
427 for (int i = 1; i < saved_argc; i++)
428 fprintf(fp, " %s", saved_argv[i]);
429 fprintf(fp, "\n\n");
430 }
431
432 profile(fp);
433
434 if (fp != stderr) fclose(fp);
435 }
436 #endif
437
438 #ifdef JTEST
439 static void jit_test(void) {
440 dflag = vm_debug = 2; vm_aflag = 1;
441 if (nmods < 2) panic("Can't find main module");
442 module m = modtab[nmods-2];
443 for (int i = 0; i < nprocs; i++) {
444 proc p = proctab[i];
445 if ((uchar *) p->p_addr >= m->m_addr
446 && (uchar *) p->p_addr < m->m_addr + m->m_length)
447 jit_compile(p->p_addr);
448 }
449 }
450 #endif
451
452 /* xmain_exit -- exit after program has finished */
453 void NORETURN xmain_exit(int status) {
454 #ifdef OBXDEB
455 debug_break(NULL, NULL, NULL, "exit");
456 #endif
457 #ifdef PROFILE
458 print_profile();
459 if (lflag) dump_lcounts();
460 #endif
461 exit(status);
462 }
463
464 /* error_exit -- exit after fatal error */
465 void NORETURN error_exit(int status) {
466 #ifdef OBXDEB
467 debug_message("quit");
468 #endif
469 exit(status);
470 }
471
472 /* The interpreter can be invoked in three ways:
473 (i) Explicitly as "obx [flags] bytefile args"
474
475 (ii) Via a #! script as "obx bytefile args"
476 or "bytefile bytefile args" under some Unixes
477
478 (iii) In a glued-together executable as "bytefile args"
479
480 Following the example of CAML Light, we recognize (iii) by seeing
481 if argv[0] names a bytefile that does not begin with #!. In that
482 case, we read that file for the bytecodes, and the program's args
483 follow immediately; otherwise, we look for flags and the name of
484 the bytefile before the program's args. In either case, we must be
485 prepared to search the shell path to find the bytefile.
486
487 These rules are modified a bit if a custom file is built for
488 profiling: in that case, we look for switches even in case (iii). */
489
490 int main(int ac, char *av[]) {
491 FILE *fp;
492 char *codefile;
493
494 argc = ac; argv = av;
495 progname = argv[0];
496
497 /* Read the command line first to handle -v */
498 codefile = search_path(argv[0]);
499 if (codefile != NULL && custom_file(codefile)) {
500 #ifdef PROFILE
501 char *prog = argv[0];
502 read_flags();
503 /* Fill the program name back in as argv[0] */
504 argc++; argv--;
505 argv[0] = prog;
506 #endif
507 } else {
508 read_flags();
509 if (argc < 1) usage();
510 codefile = search_path(argv[0]);
511 }
512
513 #ifdef OBXDEB
514 /* Now connect to the debugger process */
515 debug_init();
516 #endif
517
518 if (codefile == NULL) panic("can't find %s", argv[0]);
519
520 gc_init();
521
522 #ifdef JIT
523 vm_debug = dflag;
524 interpreter = wrap_prim(jit_trap);
525 #else
526 interpreter = wrap_prim(interp);
527 #endif
528 dyntrap = wrap_prim(dltrap);
529 #ifdef USEFFI
530 dynstub = wrap_prim(dlstub);
531 #endif
532
533 #ifdef M64X32
534 /* Allocate ob_res and statlink in 32-bit addressible storage */
535 _result = (value *) scratch_alloc(2 * sizeof(value));
536 _stat = (value **) scratch_alloc(sizeof(value *));
537 #endif
538
539 fp = fopen(codefile, "rb");
540 if (fp == NULL) panic("can't open %s", codefile);
541 load_file(fp);
542 fclose(fp);
543
544 #ifdef TRACE
545 if (dflag) dump();
546 if (qflag) exit(0);
547 #endif
548
549 #ifdef JTEST
550 if (tflag) {
551 jit_test();
552 exit(0);
553 }
554 #endif
555
556 #ifdef PROFILE
557 if (nprocs == 0)
558 panic("no symbol table in object file");
559
560 prof_init();
561 #endif
562
563 #ifdef OBXDEB
564 debug_break(NULL, NULL, NULL, "ready");
565 #endif
566 #ifdef DEBUG
567 if (dflag)
568 printf("Starting program at address %ld\n",
569 (long) ((uchar *) entry - dmem));
570 #endif
571 run(entry);
572 xmain_exit(0);
573 }
574
575 #ifdef JIT
576 void interp(value *bp) {
577 panic("dummy interp called");
578 }
579 #endif
580
581 word wrap_prim(primitive *prim) {
582 #ifdef JIT
583 return vm_wrap((funptr) prim);
584 #else
585 #ifndef M64X32
586 return (word) prim;
587 #else
588 primitive **wrapper =
589 (primitive **) scratch_alloc(sizeof(primitive *));
590 *wrapper = prim;
591 return address(wrapper);
592 #endif
593 #endif
594 }