mescc: Output performance hacks: use core:display.
authorJan Nieuwenhuizen <janneke@gnu.org>
Sat, 9 Dec 2017 19:10:57 +0000 (20:10 +0100)
committerJan Nieuwenhuizen <janneke@gnu.org>
Sat, 9 Dec 2017 19:10:57 +0000 (20:10 +0100)
* 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
module/mes/guile.mes
module/mes/guile.scm
src/lib.c

index 52ecd7045de81bb923146a971107d96e52d4e42f..7868ec46dfa889c99e5d81940c312cdecc428e6f 100644 (file)
 
 (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))
          (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)
                    (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))
index b0a0e5f2a39057c9f41fa3eb42450e590eeff1ed..29fa9580966a3e1450e1b2cf0e3b902e41323c5a 100644 (file)
@@ -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)
 
 (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
   (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
                               (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)))))
index 3f46f7f94972f6b0f0c5cd4b2ffe280b607eab41..efb9f78ffb758cdd4fd9665727fc7d2611d55ad9 100644 (file)
 
 ;;; 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)
index 4fdf591e75a5186966e4fe28744cbc45a3762c18..31916200afacc555563292d740289053b5b576c1 100644 (file)
--- 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