andrius
/
mes
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

core: Tune debug printing. 

* src/mes.c: Tune debug printing.
* src/gc.c: Likewise.
* module/mes/guile.mes: Likewise.
* HACKING: Describe it.
This commit is contained in:
Jan Nieuwenhuizen 2018-04-09 07:12:38 +02:00
parent 72fc46a572
commit b65e57be31
No known key found for this signature in database
GPG Key ID: F3C1A0D9C1D65273
8 changed files with 124 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

68
HACKING
View File

@ -2,7 +2,16 @@
* SETUP
guix environment -l guix.scm #64 bit + 32bit
or
guix environment --system=i686-linux -l guix.scm #32 bit only
or
guix package --profile=~/.config/guix/mes --manifest=build-aux/manifest.scm
. ~/.config/guix/mes/etc/profile
* BUILD
There are two major modes to build Mes: true bootstrap and
development.
@ -18,32 +27,48 @@ To help development we assume ./configure sets these variables for make
M1 -- M1
PREFIX -- ""
Mes is supposed to serve as a full equivalent for Guile, however mes is much, much
slower than guile. That's why we usually don't use mes during development.
Mes is supposed to serve as a full equivalent for Guile, however Mes
~30 times slower than Guile. That's why we usually don't use Mes
during development.
gcc is used to verify the sanity of our C sources.
Gcc is used to verify the sanity of our C sources.
i686-unknown-linux-gnu-gcc is used to compare hex/assembly, to test
the gcc variant of mes libc: lib/libc-gcc.c and steal ideas.
the gcc variant of Mes-libc: lib/libc-gcc.c and steal ideas. Target
prefix: mlibc-gcc.
Guile is used to develop mescc, the C compiler in Scheme that during
bootstrapping will be executed by mes.
** BOOTSTRAP BUILD
In bootstrap mode, we don't have gcc (CC), we don't have pa 32 bit gcc
(CC32), we have no guile (GUILE)...but we should have hex2, M1, and
FIXME: mes.M1.
Guile is used to develop MesCC, the C compiler in Scheme that during
bootstrapping will be executed by Mes.
mes is built from src/*.c and some out/src/*.h files that are snarfed from
src/*.c by build-aux/mes-snarf.scm.
Running ./make.scm produces a `script' file.
** BOOTSTRAP BUILD
./build.sh
In bootstrap mode, we don't have gcc (CC), we don't have a 32 bit gcc
(CC32), we have no guile (GUILE)...but we should have hex2, M1, and
mes.M1. That's a bootstrap problem which is currently ignored by
using the mes-seed package. mes.M1 will be produced by M2-Planet from
mes.c.
* ROADMAP
** TODO
*** release 0.x, unsorted
- mes+mescc: compile a mes-tcc that can compile gcc-4.7.
- mes: set base-0.scm as default MES_BOOT, drop cat base-0.mes silliness.
- mes: real module support, bonus for supporting Guile's define-module/define-public syntax.
- mes: prepare src/mes.c for M2-Planet transpiler.
- mes: produce functional mes from mes.M1 transpiled by M2-Planet.
- mes: we're a full Scheme now, drop .MES prefix, use .SCM.
+ find a way to fix foo.mes/foo.scm trickery (full Guile-like module support?)
+ how about setting `guile' or even `guile-2' cond-expand features
for external libraries (Nyacc) we look like Guile/Guile-2
internally, we could make sure to start every cond-expand with (mes)
- mes: use more efficient scheme continuation stack (wip-array?)
- mes: drop SCM stack in C / implement call/cc a la guile-1.8 setjmp?
- mescc: refactor type(/ptr?) system; expr->type and ast-type->type.
@ -66,7 +91,6 @@ Running ./make.scm produces a `script' file.
- mescc: some success with 8cc,pcc,guile/libguile/eval.c.
- build: guile/guix/make.scm: add file-types, intermediate, hash all dependencies
- build: make.scm: imperative->declaritive
- mes: real module support, bonus for supporting Guile's define-module/define-public syntax.
- get full source syntax-case up (Andre van Tonder?) OR drop it.
https://srfi.schemers.org/srfi-72/srfi-72.html
psyntax/syntax-case and rewrite Nyacc without syntax-case+R7RS Ellipsis.
@ -91,6 +115,26 @@ eenough to work on compiling tinycc's tcc.c albeit a somewhat modified version.
*** 0.2: Support psyntax
*** 0.1: Mes eval/apply feature complete; support syntax-rules, compile main.c using LALR, dump ELF
* DEBUG
MES_DEBUG=<level> mes
** Levels
1) Informational:
- MODULEDIR
- included SCM modules and sources
- result of program
- gc stats at exit
2) opened files
3) runtime gc stats
4) detailed info
- parsed, expanded program
- list of builtins
- list of symbol
- opened input strings
- gc details
5) usage of opened input strings
* Bugs
** mes: remove pmatch-car/pmatch-cdr hack.
** mes+mescc: parse tcc.c->tcc.E works, compile tcc.E -> tcc.M1 segfaults.

24
module/mes/guile.mes
View File

@ -48,7 +48,7 @@
(if (eq? c #\*eof*) '()
(cons c (read-string (read-char)))))
(let ((string (list->string (read-string (read-char)))))
(if (and=> (getenv "MES_DEBUG") (compose (cut > <> 2) string->number))
(if (and=> (getenv "MES_DEBUG") (compose (cut > <> 3) string->number))
(core:display-error (string-append "drained: `" string "'\n")))
string)))
@ -68,7 +68,7 @@
(define save-peek-char peek-char)
(define save-read-char read-char)
(define save-unread-char unread-char)
(if (and=> (getenv "MES_DEBUG") (compose (cut > <> 2) string->number))
(if (and=> (getenv "MES_DEBUG") (compose (cut > <> 3) string->number))
(core:display-error (string-append "with-input-from-string: `" string "'\n")))
(let ((tell 0)
(end (string-length string)))
@ -118,19 +118,21 @@
(define core:open-input-file open-input-file)
(define (open-input-file file)
(let ((port (core:open-input-file file)))
(when (getenv "MES_DEBUG")
(core:display-error (string-append "open-input-file: `" file "'\n"))
(core:display-error "port=")
(core:display-error port)
(core:display-error "\n"))
(let ((port (core:open-input-file file))
(debug (and=> (getenv "MES_DEBUG") string->number)))
(when (and debug (> debug 1))
(core:display-error (string-append "open-input-file: `" file "'"))
(when (> debug 3)
(core:display-error " port=")
(core:display-error port)))
(core:display-error "\n")
port))
(define open-input-string
(let ((save-set-current-input-port #f)
(string-port #f))
(lambda (string)
(if (and=> (getenv "MES_DEBUG") (compose (cut > <> 2) string->number))
(if (and=> (getenv "MES_DEBUG") (compose (cut > <> 3) string->number))
(core:display-error (string-append "open-input-string: `" string "'\n")))
(set! save-set-current-input-port set-current-input-port)
(set! string-port (cons '*string-port* (gensym)))
@ -141,7 +143,7 @@
(tell 0)
(end (string-length string)))
(lambda (port)
(when (and=> (getenv "MES_DEBUG") (compose (cut > <> 2) string->number))
(when (and=> (getenv "MES_DEBUG") (compose (cut > <> 5) string->number))
(core:display-error (string-append "open-input-string: `" string "' save-set-current-input-port port="))
(core:display-error port)
(core:display-error "\n"))
@ -160,7 +162,7 @@
(lambda (c) (set! tell (1- tell)) c))
(set! set-current-input-port
(lambda (port)
(when (getenv "MES_DEBUG")
(when (and=> (getenv "MES_DEBUG") (compose (cut > <> 4) string->number))
(core:display-error (string-append "open-input-string: `" string "' set-current-input-port port="))
(core:display-error port)
(core:display-error "\n"))

8
module/mes/module.mes
View File

@ -32,7 +32,7 @@
'begin
(list 'set! '*modules* (list cons (list string->symbol (module->file module)) '*modules*))
(list 'load (list string-append '%moduledir (module->file module))))
(list 'if (getenv "MES_DEBUG")
(list 'if (and (getenv "MES_DEBUG") (list '> (list 'core:cdr (list 'car (list 'string->list (getenv "MES_DEBUG")))) 50))
(list 'begin
(list core:display-error ";;; already loaded: ")
(list core:display-error (list 'quote module))
@ -58,7 +58,5 @@
(set-current-input-port (pop! *input-ports*))
x))
(define (mes-load-module-env module a)
(core:display-error "loading:") (core:write-error (string-append %moduledir (module->file module))) (core:display-error "\n")
(primitive-load (string-append %moduledir (module->file module)))
(core:display-error "dun\n")
)
(core:write-error (string-append %moduledir (module->file module))) (core:display-error "\n")
(primitive-load (string-append %moduledir (module->file module))))

6
scaffold/boot/51-module.scm
View File

@ -35,6 +35,12 @@
(if (null? (cdr rest)) (car rest)
(append2 (car rest) (apply append (cdr rest))))))
(define-macro (and . x)
(if (null? x) #t
(if (null? (cdr x)) (car x)
(list (quote if) (car x) (cons (quote and) (cdr x))
#f))))
(define (string->list s)
(core:car s))

6
scaffold/boot/52-define-module.scm
View File

@ -34,6 +34,12 @@
(if (null? (cdr rest)) (car rest)
(append2 (car rest) (apply append (cdr rest))))))
(define-macro (and . x)
(if (null? x) #t
(if (null? (cdr x)) (car x)
(list (quote if) (car x) (cons (quote and) (cdr x))
#f))))
(define (string->list s)
(core:car s))

2
scripts/mescc.mes
View File

@ -159,4 +159,4 @@ Usage: mescc.mes [OPTION]... FILE...
(objects->elf objects))))))))))
(main (command-line))
()
'done

8
src/gc.c
View File

@ -48,7 +48,7 @@ gc_flip () ///((internal))
struct scm *cells = g_cells;
g_cells = g_news;
g_news = cells;
if (g_debug > 1)
if (g_debug > 2)
{
eputs (";;; => jam[");
eputs (itoa (g_free));
@ -137,9 +137,9 @@ gc_check ()
SCM
gc ()
{
if (g_debug == 1)
if (g_debug == 2)
eputs (".");
if (g_debug > 1)
if (g_debug > 2)
{
eputs (";;; gc[");
eputs (itoa (g_free));
@ -156,7 +156,7 @@ gc ()
g_symbols = gc_copy (g_symbols);
g_macros = gc_copy (g_macros);
SCM new = gc_copy (g_stack);
if (g_debug > 1)
if (g_debug > 3)
{
eputs ("new=");
eputs (itoa (new));

54
src/mes.c
View File

@ -430,11 +430,13 @@ car_ (SCM x)
SCM
cdr_ (SCM x)
{
return (TYPE (CDR (x)) == TPAIR
|| TYPE (CDR (x)) == TREF
|| TYPE (CAR (x)) == TSPECIAL
|| TYPE (CDR (x)) == TSYMBOL
|| TYPE (CDR (x)) == TSTRING) ? CDR (x) : MAKE_NUMBER (CDR (x));
return (TYPE (x) != TCHAR
&& TYPE (x) != TNUMBER
&& (TYPE (CDR (x)) == TPAIR
|| TYPE (CDR (x)) == TREF
|| TYPE (CDR (x)) == TSPECIAL
|| TYPE (CDR (x)) == TSYMBOL
|| TYPE (CDR (x)) == TSTRING)) ? CDR (x) : MAKE_NUMBER (CDR (x));
}
SCM
@ -573,7 +575,7 @@ check_formals (SCM f, SCM formals, SCM args) ///((internal))
eputs (", got: ");
eputs (itoa (alen));
eputs ("\n");
display_error_ (f);
write_error_ (f);
SCM e = MAKE_STRING (cstring_to_list (s));
return error (cell_symbol_wrong_number_of_args, cons (e, f));
}
@ -1574,15 +1576,10 @@ mes_symbols () ///((internal))
a = acons (cell_symbol_mes_version, MAKE_STRING (cstring_to_list (VERSION)), a);
a = acons (cell_symbol_mes_prefix, MAKE_STRING (cstring_to_list (PREFIX)), a);
a = acons (cell_symbol_dot, cell_dot, a);
a = acons (cell_symbol_begin, cell_begin, a);
a = acons (cell_symbol_quasisyntax, cell_symbol_quasisyntax, a);
a = acons (cell_symbol_call_with_values, cell_symbol_call_with_values, a);
a = acons (cell_symbol_current_module, cell_symbol_current_module, a);
a = acons (cell_symbol_call_with_current_continuation, cell_call_with_current_continuation, a);
a = acons (cell_symbol_sc_expand, cell_f, a);
#if __GNUC__
a = acons (cell_symbol_gnuc, cell_t, a);
@ -1644,7 +1641,7 @@ mes_builtins (SCM a) ///((internal))
#include "vector.environment.i"
#endif
if (g_debug > 1)
if (g_debug > 3)
{
fputs ("functions: ", STDERR);
fputs (itoa (g_function), STDERR);
@ -1789,7 +1786,7 @@ bload_env (SCM a) ///((internal))
set_env_x (cell_symbol_mesc, cell_t, r0);
#endif
if (g_debug > 1)
if (g_debug > 3)
{
eputs ("symbols: ");
SCM s = g_symbols;
@ -1828,7 +1825,8 @@ main (int argc, char *argv[])
if (g_debug)
{
eputs (";;; MODULEDIR=");
eputs (MODULEDIR);eputs ("\n");
eputs (MODULEDIR);
eputs ("\n");
}
if (p = getenv ("MES_MAX_ARENA"))
MAX_ARENA_SIZE = atoi (p);
@ -1857,21 +1855,39 @@ main (int argc, char *argv[])
r0 = acons (cell_symbol_argv, lst, r0); // FIXME
r0 = acons (cell_symbol_argv, lst, r0);
push_cc (r2, cell_unspecified, r0, cell_unspecified);
if (g_debug > 1)
if (g_debug > 2)
{
eputs ("\ngc stats: [");
eputs (itoa (g_free));
eputs ("]\n");
}
if (g_debug > 3)
{
eputs ("program: ");
write_error_ (r1);
eputs ("\n");
}
if (g_debug > 3)
{
eputs ("symbols: ");
write_error_ (g_symbols);
eputs ("\n");
}
r3 = cell_vm_begin_expand;
r1 = eval_apply ();
write_error_ (r1);
eputs ("\n");
if (g_debug)
{
gc (g_stack);
write_error_ (r1);
eputs ("\n");
}
if (g_debug)
{
eputs ("\ngc stats: [");
eputs (itoa (g_free));
gc (g_stack);
eputs (" => ");
eputs (itoa (g_free));
eputs ("]\n");
}
return 0;