From ccddde9a845dc7819df56554e0687f0f470cf94c Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 9 Dec 2017 20:10:57 +0100 Subject: [PATCH] mescc: Output performance hacks: use core:display. * src/lib.c (display_): Write to g_stdout (WAS: STDOUT). * module/mes/guile.scm (guile): Declare and export core:display core:display-error. * module/mes/M1.mes (object->M1): Use core:display and string-append instead of format. * module/mes/guile.mes (with-input-from-string): Add debugging. (open-input-string): Likewise. (read-string): Likewise. Re-implement. (drain-input): Use read-string. --- module/mes/M1.mes | 64 +++++++++++++++++++++++--------------------- module/mes/guile.mes | 29 +++++++++++--------- module/mes/guile.scm | 9 ++++++- src/lib.c | 2 +- 4 files changed, 60 insertions(+), 44 deletions(-) diff --git a/module/mes/M1.mes b/module/mes/M1.mes index 52ecd704..7868ec46 100644 --- a/module/mes/M1.mes +++ b/module/mes/M1.mes @@ -78,11 +78,11 @@ (define (hex2:immediate o) (if hex? (string-append "%0x" (dec->hex o)) - (format #f "%~a" o))) + (string-append "%" (number->string o)))) (define (hex2:immediate1 o) (if hex? (string-append "!0x" (dec->hex o)) - (format #f "!~a" o))) + (string-append "!" (number->string o)))) (define (object->M1 o) (let* ((functions (assoc-ref o 'functions)) @@ -93,41 +93,45 @@ (strings (filter (lambda (g) (and (pair? g) (eq? (car g) #:string))) global-names))) (define (string->label o) (let ((index (list-index (lambda (s) (equal? s o)) strings))) - (format #f "_string_~a_~a" file-name index))) + (if index + (string-append "_string_" file-name "_" (number->string index)) + ""))) (define (text->M1 o) - (pmatch o - ;; FIXME - ((#:address (#:string ,string)) (hex2:address (string->label `(#:string ,string)))) - ((#:string (#:address ,address)) (hex2:address address)) - ((#:address (#:address ,address)) (hex2:address address)) - - ((#:string ,string) (hex2:address (string->label o))) - ((#:address ,address) (hex2:address address)) - ((#:offset ,offset) (hex2:offset offset)) - ((#:offset1 ,offset1) (hex2:offset1 offset1)) - ((#:immediate ,immediate) (hex2:immediate immediate)) - ((#:immediate1 ,immediate1) (hex2:immediate1 immediate1)) - (_ (cond ((char? o) (text->M1 (char->integer o))) - ((string? o) (format #f "~a" o)) - ((number? o) (let ((o (if (< o #x80) o (- o #x100)))) - (if hex? (string-append "!0x" - (if (and (>= o 0) (< o 16)) "0" "") - (number->string o 16)) - (string-append "!" (number->string o))))) - (else (format #f "~a" o)))))) + (cond + ((char? o) (text->M1 (char->integer o))) + ((string? o) o) + ((symbol? o) (symbol->string o)) + ((number? o) (let ((o (if (< o #x80) o (- o #x100)))) + (if hex? (string-append "!0x" + (if (and (>= o 0) (< o 16)) "0" "") + (number->string o 16)) + (string-append "!" (number->string o))))) + ((and (pair? o) (keyword? (car o))) + (pmatch o + ;; FIXME + ((#:address (#:string ,string)) (hex2:address (string->label `(#:string ,string)))) + ((#:string (#:address ,address)) (hex2:address address)) + ((#:address (#:address ,address)) (hex2:address address)) + ((#:string ,string) (hex2:address (string->label o))) + ((#:address ,address) (hex2:address address)) + ((#:offset ,offset) (hex2:offset offset)) + ((#:offset1 ,offset1) (hex2:offset1 offset1)) + ((#:immediate ,immediate) (hex2:immediate immediate)) + ((#:immediate1 ,immediate1) (hex2:immediate1 immediate1)))) + ((pair? o) (string-join (map text->M1 o))))) (define (write-function o) (let ((name (car o)) (text (cdr o))) (define (line->M1 o) (cond ((eq? (car o) #:label) - (format #t ":~a" (cadr o))) + (core:display (string-append ":" (cadr o)))) ((eq? (car o) #:comment) - (format #t "\t\t\t\t\t# ~a" (cadr o))) + (core:display (string-append "\t\t\t\t\t# " (text->M1 (cadr o))))) ((or (string? (car o)) (symbol? (car o))) - (format #t "\t~a" (string-join (map text->M1 o) " "))) + (core:display (string-append "\t" (string-join (map text->M1 o) " ")))) (else (error "line->M1 invalid line:" o))) (newline)) - (format #t "\n\n:~a\n" name) + (core:display (string-append "\n\n:" name "\n")) (for-each line->M1 (apply append text)))) (define (write-global o) (define (labelize o) @@ -137,11 +141,11 @@ (string-label (string->label label)) (string? (not (equal? string-label "_string_#f"))) (global? (member label global-names))) - (if (or global? string?) (format #f "&~a" label) + (if (or global? string?) (string-append "&" label) (begin (if (not function?) (stderr "warning: unresolved label: ~s\n" label)) - (format #f "&~a" label)))))) + (string-append "&" label)))))) (let* ((label (if (not (and (pair? (car o)) (eq? (caar o) #:string))) (car o) - (string->label (car o)))) + (string->label (car o)))) (data (cdr o)) (data (filter-map labelize data)) (len (length data)) diff --git a/module/mes/guile.mes b/module/mes/guile.mes index b0a0e5f2..29fa9580 100644 --- a/module/mes/guile.mes +++ b/module/mes/guile.mes @@ -28,7 +28,9 @@ (define-macro (include-from-path file) (let loop ((path (cons %moduledir (string-split (or (getenv "GUILE_LOAD_PATH") "") #\:)))) - (if (getenv "MES_DEBUG") (format (current-error-port) "include-from-path: ~s [PATH:~s]\n" file path)) + (if (getenv "MES_DEBUG") + ;;(format (current-error-port) "include-from-path: ~s [PATH:~s]\n" file path) + (core:display-error (string-append "include-from-path: " file " [PATH:" (string-join path ":") "]\n"))) (if (null? path) (error "include-from-path: not found: " file) (let ((file (string-append (car path) "/" file))) (if (access? file R_OK) `(load ,file) @@ -36,11 +38,16 @@ (mes-use-module (srfi srfi-16)) -(define (drain-input port) - (list->string - (let loop ((c (read-char))) - (if (eq? c #\*eof*) '() - (cons c (loop (read-char))))))) +(define (read-string) + (define (read-string c) + (if (eq? c #\*eof*) '() + (cons c (read-string (read-char))))) + (let ((string (list->string (read-string (read-char))))) + (if (getenv "MES_DEBUG") + (core:display-error (string-append "drained: `" string "'\n"))) + string)) + +(define (drain-input port) (read-string)) (define (make-string n . fill) (list->string (apply make-list n fill))) @@ -57,6 +64,8 @@ (define save-peek-char peek-char) (define save-read-char read-char) (define save-unread-char unread-char) + (if (getenv "MES_DEBUG") + (core:display-error (string-append "with-input-from-string: `" string "'\n"))) (let ((tell 0) (end (string-length string))) (set! peek-char @@ -106,6 +115,8 @@ (let ((save-set-current-input-port #f) (string-port #f)) (lambda (string) + (if (getenv "MES_DEBUG") + (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))) (set! set-current-input-port @@ -136,9 +147,3 @@ (set! set-current-input-port save-set-current-input-port) string-port))))))) string-port))) - -(define (read-string) - (define (read-string c p s) - (if (eq? c #\*eof*) s - (read-string (read-char) (peek-char) (cons c s)))) - (list->string (reverse (read-string (read-char) (peek-char) (list))))) diff --git a/module/mes/guile.scm b/module/mes/guile.scm index 3f46f7f9..efb9f78f 100644 --- a/module/mes/guile.scm +++ b/module/mes/guile.scm @@ -22,7 +22,14 @@ ;;; Code: -(define-module (mes guile)) +(define-module (mes guile) + #:export (core:display core:display-error)) + +(cond-expand + (guile + (define core:display display) + (define (core:display-error o) (display o (current-error-port)))) + (mes)) (cond-expand (guile-2.2) diff --git a/src/lib.c b/src/lib.c index 4fdf591e..31916200 100644 --- a/src/lib.c +++ b/src/lib.c @@ -108,7 +108,7 @@ SCM display_ (SCM x) { g_depth = 5; - return display_helper (x, 0, "", STDOUT); + return display_helper (x, 0, "", g_stdout); } SCM