From b65e57be314f200dda422e342c418ba1e793f052 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Mon, 9 Apr 2018 07:12:38 +0200 Subject: [PATCH] core: Tune debug printing. * src/mes.c: Tune debug printing. * src/gc.c: Likewise. * module/mes/guile.mes: Likewise. * HACKING: Describe it. --- HACKING | 68 ++++++++++++++++++++++++------ module/mes/guile.mes | 24 ++++++----- module/mes/module.mes | 8 ++-- scaffold/boot/51-module.scm | 6 +++ scaffold/boot/52-define-module.scm | 6 +++ scripts/mescc.mes | 2 +- src/gc.c | 8 ++-- src/mes.c | 54 +++++++++++++++--------- 8 files changed, 124 insertions(+), 52 deletions(-) diff --git a/HACKING b/HACKING index 2af5d6d7..0b4620ed 100644 --- a/HACKING +++ b/HACKING @@ -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= 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. diff --git a/module/mes/guile.mes b/module/mes/guile.mes index 321e2cc5..8009f96d 100644 --- a/module/mes/guile.mes +++ b/module/mes/guile.mes @@ -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")) diff --git a/module/mes/module.mes b/module/mes/module.mes index be55eaa8..716ca3b6 100644 --- a/module/mes/module.mes +++ b/module/mes/module.mes @@ -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)))) diff --git a/scaffold/boot/51-module.scm b/scaffold/boot/51-module.scm index 2205dc5a..f5e856e9 100644 --- a/scaffold/boot/51-module.scm +++ b/scaffold/boot/51-module.scm @@ -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)) diff --git a/scaffold/boot/52-define-module.scm b/scaffold/boot/52-define-module.scm index 5b7e0c17..81fa9ee8 100644 --- a/scaffold/boot/52-define-module.scm +++ b/scaffold/boot/52-define-module.scm @@ -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)) diff --git a/scripts/mescc.mes b/scripts/mescc.mes index 082f45b4..2e6639c5 100755 --- a/scripts/mescc.mes +++ b/scripts/mescc.mes @@ -159,4 +159,4 @@ Usage: mescc.mes [OPTION]... FILE... (objects->elf objects)))))))))) (main (command-line)) -() +'done diff --git a/src/gc.c b/src/gc.c index 9cab3e8b..1a50b739 100644 --- a/src/gc.c +++ b/src/gc.c @@ -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)); diff --git a/src/mes.c b/src/mes.c index 1667969b..a627a302 100644 --- a/src/mes.c +++ b/src/mes.c @@ -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;